{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}
module Development.Shake.Internal.Core.Database(
Locked, runLocked,
DatabasePoly, createDatabase,
mkId,
getValueFromKey, getIdFromKey, getKeyValues, getKeyValueFromId, getKeyValuesFromId,
setMem, setDisk, modifyAllMem
) where
import Data.Tuple.Extra
import Data.IORef.Extra
import General.Intern(Id, Intern)
import Development.Shake.Classes
import qualified Data.HashMap.Strict as Map
import qualified General.Intern as Intern
import Control.Concurrent.Extra
import Control.Monad.IO.Class
import qualified General.Ids as Ids
import Control.Monad.Fail
import Prelude
newtype Locked a = Locked (IO a)
deriving (a -> Locked b -> Locked a
(a -> b) -> Locked a -> Locked b
(forall a b. (a -> b) -> Locked a -> Locked b)
-> (forall a b. a -> Locked b -> Locked a) -> Functor Locked
forall a b. a -> Locked b -> Locked a
forall a b. (a -> b) -> Locked a -> Locked b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Locked b -> Locked a
$c<$ :: forall a b. a -> Locked b -> Locked a
fmap :: (a -> b) -> Locked a -> Locked b
$cfmap :: forall a b. (a -> b) -> Locked a -> Locked b
Functor, Functor Locked
a -> Locked a
Functor Locked =>
(forall a. a -> Locked a)
-> (forall a b. Locked (a -> b) -> Locked a -> Locked b)
-> (forall a b c.
(a -> b -> c) -> Locked a -> Locked b -> Locked c)
-> (forall a b. Locked a -> Locked b -> Locked b)
-> (forall a b. Locked a -> Locked b -> Locked a)
-> Applicative Locked
Locked a -> Locked b -> Locked b
Locked a -> Locked b -> Locked a
Locked (a -> b) -> Locked a -> Locked b
(a -> b -> c) -> Locked a -> Locked b -> Locked c
forall a. a -> Locked a
forall a b. Locked a -> Locked b -> Locked a
forall a b. Locked a -> Locked b -> Locked b
forall a b. Locked (a -> b) -> Locked a -> Locked b
forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Locked a -> Locked b -> Locked a
$c<* :: forall a b. Locked a -> Locked b -> Locked a
*> :: Locked a -> Locked b -> Locked b
$c*> :: forall a b. Locked a -> Locked b -> Locked b
liftA2 :: (a -> b -> c) -> Locked a -> Locked b -> Locked c
$cliftA2 :: forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
<*> :: Locked (a -> b) -> Locked a -> Locked b
$c<*> :: forall a b. Locked (a -> b) -> Locked a -> Locked b
pure :: a -> Locked a
$cpure :: forall a. a -> Locked a
$cp1Applicative :: Functor Locked
Applicative, Applicative Locked
a -> Locked a
Applicative Locked =>
(forall a b. Locked a -> (a -> Locked b) -> Locked b)
-> (forall a b. Locked a -> Locked b -> Locked b)
-> (forall a. a -> Locked a)
-> Monad Locked
Locked a -> (a -> Locked b) -> Locked b
Locked a -> Locked b -> Locked b
forall a. a -> Locked a
forall a b. Locked a -> Locked b -> Locked b
forall a b. Locked a -> (a -> Locked b) -> Locked b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Locked a
$creturn :: forall a. a -> Locked a
>> :: Locked a -> Locked b -> Locked b
$c>> :: forall a b. Locked a -> Locked b -> Locked b
>>= :: Locked a -> (a -> Locked b) -> Locked b
$c>>= :: forall a b. Locked a -> (a -> Locked b) -> Locked b
$cp1Monad :: Applicative Locked
Monad, Monad Locked
Monad Locked => (forall a. IO a -> Locked a) -> MonadIO Locked
IO a -> Locked a
forall a. IO a -> Locked a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Locked a
$cliftIO :: forall a. IO a -> Locked a
$cp1MonadIO :: Monad Locked
MonadIO, Monad Locked
Monad Locked => (forall a. String -> Locked a) -> MonadFail Locked
String -> Locked a
forall a. String -> Locked a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> Locked a
$cfail :: forall a. String -> Locked a
$cp1MonadFail :: Monad Locked
MonadFail)
runLocked :: DatabasePoly k v -> Locked b -> IO b
runLocked :: DatabasePoly k v -> Locked b -> IO b
runLocked db :: DatabasePoly k v
db (Locked act :: IO b
act) = Lock -> IO b -> IO b
forall a. Lock -> IO a -> IO a
withLock (DatabasePoly k v -> Lock
forall k v. DatabasePoly k v -> Lock
lock DatabasePoly k v
db) IO b
act
data DatabasePoly k v = Database
{DatabasePoly k v -> Lock
lock :: Lock
,DatabasePoly k v -> IORef (Intern k)
intern :: IORef (Intern k)
,DatabasePoly k v -> Ids (k, v)
status :: Ids.Ids (k, v)
,DatabasePoly k v -> Id -> k -> v -> IO ()
journal :: Id -> k -> v -> IO ()
,DatabasePoly k v -> v
vDefault :: v
}
createDatabase
:: (Eq k, Hashable k)
=> Ids.Ids (k, v)
-> (Id -> k -> v -> IO ())
-> v
-> IO (DatabasePoly k v)
createDatabase :: Ids (k, v) -> (Id -> k -> v -> IO ()) -> v -> IO (DatabasePoly k v)
createDatabase status :: Ids (k, v)
status journal :: Id -> k -> v -> IO ()
journal vDefault :: v
vDefault = do
[(Id, (k, v))]
xs <- Ids (k, v) -> IO [(Id, (k, v))]
forall a. Ids a -> IO [(Id, a)]
Ids.toList Ids (k, v)
status
IORef (Intern k)
intern <- Intern k -> IO (IORef (Intern k))
forall a. a -> IO (IORef a)
newIORef (Intern k -> IO (IORef (Intern k)))
-> Intern k -> IO (IORef (Intern k))
forall a b. (a -> b) -> a -> b
$ [(k, Id)] -> Intern k
forall a. (Eq a, Hashable a) => [(a, Id)] -> Intern a
Intern.fromList [(k
k, Id
i) | (i :: Id
i, (k :: k
k,_)) <- [(Id, (k, v))]
xs]
Lock
lock <- IO Lock
newLock
DatabasePoly k v -> IO (DatabasePoly k v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Database :: forall k v.
Lock
-> IORef (Intern k)
-> Ids (k, v)
-> (Id -> k -> v -> IO ())
-> v
-> DatabasePoly k v
Database{..}
getValueFromKey :: (Eq k, Hashable k) => DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey :: DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey Database{..} k :: k
k = do
Intern k
is <- IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
case k -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is of
Nothing -> Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
Just i :: Id
i -> ((k, v) -> v) -> Maybe (k, v) -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k, v) -> v
forall a b. (a, b) -> b
snd (Maybe (k, v) -> Maybe v) -> IO (Maybe (k, v)) -> IO (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ids (k, v) -> Id -> IO (Maybe (k, v))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup Ids (k, v)
status Id
i
getKeyValueFromId :: DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId :: DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId Database{..} = Ids (k, v) -> Id -> IO (Maybe (k, v))
forall a. Ids a -> Id -> IO (Maybe a)
Ids.lookup Ids (k, v)
status
getKeyValues :: DatabasePoly k v -> IO [(k, v)]
getKeyValues :: DatabasePoly k v -> IO [(k, v)]
getKeyValues Database{..} = Ids (k, v) -> IO [(k, v)]
forall a. Ids a -> IO [a]
Ids.elems Ids (k, v)
status
getKeyValuesFromId :: DatabasePoly k v -> IO (Map.HashMap Id (k, v))
getKeyValuesFromId :: DatabasePoly k v -> IO (HashMap Id (k, v))
getKeyValuesFromId Database{..} = Ids (k, v) -> IO (HashMap Id (k, v))
forall a. Ids a -> IO (HashMap Id a)
Ids.toMap Ids (k, v)
status
getIdFromKey :: (Eq k, Hashable k) => DatabasePoly k v -> IO (k -> Maybe Id)
getIdFromKey :: DatabasePoly k v -> IO (k -> Maybe Id)
getIdFromKey Database{..} = do
Intern k
is <- IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
(k -> Maybe Id) -> IO (k -> Maybe Id)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((k -> Maybe Id) -> IO (k -> Maybe Id))
-> (k -> Maybe Id) -> IO (k -> Maybe Id)
forall a b. (a -> b) -> a -> b
$ (k -> Intern k -> Maybe Id) -> Intern k -> k -> Maybe Id
forall a b c. (a -> b -> c) -> b -> a -> c
flip k -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Intern k
is
mkId :: (Eq k, Hashable k) => DatabasePoly k v -> k -> Locked Id
mkId :: DatabasePoly k v -> k -> Locked Id
mkId Database{..} k :: k
k = IO Id -> Locked Id
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Id -> Locked Id) -> IO Id -> Locked Id
forall a b. (a -> b) -> a -> b
$ do
Intern k
is <- IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
case k -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is of
Just i :: Id
i -> Id -> IO Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
Nothing -> do
(is :: Intern k
is, i :: Id
i)<- (Intern k, Id) -> IO (Intern k, Id)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Intern k, Id) -> IO (Intern k, Id))
-> (Intern k, Id) -> IO (Intern k, Id)
forall a b. (a -> b) -> a -> b
$ k -> Intern k -> (Intern k, Id)
forall a. (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
Intern.add k
k Intern k
is
Ids (k, v) -> Id -> (k, v) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert Ids (k, v)
status Id
i (k
k, v
vDefault)
IORef (Intern k) -> Intern k -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef' IORef (Intern k)
intern Intern k
is
Id -> IO Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
setMem :: DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem :: DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database{..} i :: Id
i k :: k
k v :: v
v = IO () -> Locked ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Locked ()) -> IO () -> Locked ()
forall a b. (a -> b) -> a -> b
$ Ids (k, v) -> Id -> (k, v) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert Ids (k, v)
status Id
i (k
k,v
v)
modifyAllMem :: DatabasePoly k v -> (v -> v) -> Locked ()
modifyAllMem :: DatabasePoly k v -> (v -> v) -> Locked ()
modifyAllMem Database{..} f :: v -> v
f = IO () -> Locked ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Locked ()) -> IO () -> Locked ()
forall a b. (a -> b) -> a -> b
$ Ids (k, v) -> ((k, v) -> (k, v)) -> IO ()
forall a. Ids a -> (a -> a) -> IO ()
Ids.forMutate Ids (k, v)
status (((k, v) -> (k, v)) -> IO ()) -> ((k, v) -> (k, v)) -> IO ()
forall a b. (a -> b) -> a -> b
$ (v -> v) -> (k, v) -> (k, v)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second v -> v
f
setDisk :: DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk :: DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk = DatabasePoly k v -> Id -> k -> v -> IO ()
forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
journal