{-# LANGUAGE BangPatterns #-}
{-# 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 ((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
$cfmap :: forall a b. (a -> b) -> Locked a -> Locked b
fmap :: forall a b. (a -> b) -> Locked a -> Locked b
$c<$ :: forall a b. a -> Locked b -> Locked a
<$ :: forall a b. a -> Locked b -> Locked a
Functor, Functor Locked
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
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
$cpure :: forall a. a -> Locked a
pure :: forall a. a -> Locked a
$c<*> :: forall a b. Locked (a -> b) -> Locked a -> Locked b
<*> :: forall a b. Locked (a -> b) -> Locked a -> Locked b
$cliftA2 :: forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
liftA2 :: forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
$c*> :: forall a b. Locked a -> Locked b -> Locked b
*> :: forall a b. Locked a -> Locked b -> Locked b
$c<* :: forall a b. Locked a -> Locked b -> Locked a
<* :: forall a b. Locked a -> Locked b -> Locked a
Applicative, Applicative Locked
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
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
$c>>= :: forall a b. Locked a -> (a -> Locked b) -> Locked b
>>= :: forall a b. Locked a -> (a -> Locked b) -> Locked b
$c>> :: forall a b. Locked a -> Locked b -> Locked b
>> :: forall a b. Locked a -> Locked b -> Locked b
$creturn :: forall a. a -> Locked a
return :: forall a. a -> Locked a
Monad, Monad Locked
Monad Locked => (forall a. IO a -> Locked a) -> MonadIO Locked
forall a. IO a -> Locked a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Locked a
liftIO :: forall a. IO a -> Locked a
MonadIO, Monad Locked
Monad Locked => (forall a. String -> Locked a) -> MonadFail Locked
forall a. String -> Locked a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> Locked a
fail :: forall a. String -> Locked a
MonadFail)
runLocked :: DatabasePoly k v -> Locked b -> IO b
runLocked :: forall k v b. DatabasePoly k v -> Locked b -> IO b
runLocked DatabasePoly k v
db (Locked 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
{forall k v. DatabasePoly k v -> Lock
lock :: Lock
,forall k v. DatabasePoly k v -> IORef (Intern k)
intern :: IORef (Intern k)
,forall k v. DatabasePoly k v -> Ids (k, v)
status :: Ids.Ids (k, v)
,forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
journal :: Id -> k -> v -> IO ()
,forall k v. 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 :: forall k v.
(Eq k, Hashable k) =>
Ids (k, v) -> (Id -> k -> v -> IO ()) -> v -> IO (DatabasePoly k v)
createDatabase Ids (k, v)
status Id -> k -> v -> IO ()
journal 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) | (Id
i, (k
k,v
_)) <- [(Id, (k, v))]
xs]
Lock
lock <- IO Lock
newLock
DatabasePoly k v -> IO (DatabasePoly k v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
intern :: IORef (Intern k)
lock :: Lock
..}
getValueFromKey :: (Eq k, Hashable k) => DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey :: forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} 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
Maybe Id
Nothing -> Maybe v -> IO (Maybe v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
Just Id
i -> ((k, v) -> v) -> Maybe (k, v) -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall k v. DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} = 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 :: forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} = 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 :: forall k v. DatabasePoly k v -> IO (HashMap Id (k, v))
getKeyValuesFromId Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} = 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 :: forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> IO (k -> Maybe Id)
getIdFromKey Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} = 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 a. a -> IO a
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 :: forall k v.
(Eq k, Hashable k) =>
DatabasePoly k v -> k -> Locked Id
mkId Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} k
k = IO Id -> Locked Id
forall a. IO a -> Locked a
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 Id
i -> Id -> IO Id
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
Maybe Id
Nothing -> do
(Intern k
is, Id
i)<- (Intern k, Id) -> IO (Intern k, Id)
forall a. a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
setMem :: DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem :: forall k v. DatabasePoly k v -> Id -> k -> v -> Locked ()
setMem Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} Id
i k
k v
v = IO () -> Locked ()
forall a. IO a -> Locked a
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 :: forall k v. DatabasePoly k v -> (v -> v) -> Locked ()
modifyAllMem Database{v
IORef (Intern k)
Lock
Ids (k, v)
Id -> k -> v -> IO ()
lock :: forall k v. DatabasePoly k v -> Lock
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
status :: forall k v. DatabasePoly k v -> Ids (k, v)
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
vDefault :: forall k v. DatabasePoly k v -> v
lock :: Lock
intern :: IORef (Intern k)
status :: Ids (k, v)
journal :: Id -> k -> v -> IO ()
vDefault :: v
..} v -> v
f = IO () -> Locked ()
forall a. IO a -> Locked a
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
$ \(k
k,v
v) ->
let !v' :: v
v' = v -> v
f v
v
in (k
k, v
v')
setDisk :: DatabasePoly k v -> Id -> k -> v -> IO ()
setDisk :: forall k v. 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