{-# 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 -> 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
<$ :: forall a b. a -> Locked b -> Locked a
$c<$ :: forall a b. a -> Locked b -> Locked a
fmap :: forall a b. (a -> b) -> Locked a -> Locked b
$cfmap :: forall a b. (a -> b) -> Locked a -> Locked b
Functor, Functor 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
<* :: forall a b. Locked a -> Locked b -> Locked a
$c<* :: forall a b. Locked a -> Locked b -> Locked a
*> :: forall a b. Locked a -> Locked b -> Locked b
$c*> :: forall a b. Locked a -> Locked b -> Locked b
liftA2 :: forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
$cliftA2 :: forall a b c. (a -> b -> c) -> Locked a -> Locked b -> Locked c
<*> :: forall a b. Locked (a -> b) -> Locked a -> Locked b
$c<*> :: forall a b. Locked (a -> b) -> Locked a -> Locked b
pure :: forall a. a -> Locked a
$cpure :: forall a. a -> Locked a
Applicative, Applicative 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
return :: forall a. a -> Locked a
$creturn :: forall a. a -> Locked a
>> :: forall a b. Locked a -> Locked b -> Locked b
$c>> :: forall a b. Locked a -> Locked b -> Locked b
>>= :: forall a b. Locked a -> (a -> Locked b) -> Locked b
$c>>= :: forall a b. Locked a -> (a -> Locked b) -> Locked b
Monad, Monad Locked
forall a. IO a -> Locked a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Locked a
$cliftIO :: forall a. IO a -> Locked a
MonadIO, Monad Locked
forall a. String -> Locked a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> Locked a
$cfail :: 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) = forall a. Lock -> IO a -> IO a
withLock (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 <- forall a. Ids a -> IO [(Id, a)]
Ids.toList Ids (k, v)
status
IORef (Intern k)
intern <- forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ 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
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)
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} k
k = do
Intern k
is <- forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
case forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is of
Maybe Id
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just Id
i -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} = 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} = 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} = 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} = do
Intern k
is <- forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} k
k = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Intern k
is <- forall a. IORef a -> IO a
readIORef IORef (Intern k)
intern
case forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is of
Just Id
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
i
Maybe Id
Nothing -> do
(Intern k
is, Id
i)<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)
Intern.add k
k Intern k
is
forall a. Ids a -> Id -> a -> IO ()
Ids.insert Ids (k, v)
status Id
i (k
k, v
vDefault)
forall a. IORef a -> a -> IO ()
writeIORef' IORef (Intern k)
intern Intern k
is
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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} Id
i k
k v
v = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 ()
vDefault :: v
journal :: Id -> k -> v -> IO ()
status :: Ids (k, v)
intern :: IORef (Intern k)
lock :: Lock
vDefault :: forall k v. DatabasePoly k v -> v
journal :: forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
status :: forall k v. DatabasePoly k v -> Ids (k, v)
intern :: forall k v. DatabasePoly k v -> IORef (Intern k)
lock :: forall k v. DatabasePoly k v -> Lock
..} v -> v
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Ids a -> (a -> a) -> IO ()
Ids.forMutate Ids (k, v)
status 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 = forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
journal