{-# LANGUAGE BangPatterns #-}{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}moduleDevelopment.Shake.Internal.Core.Database(Locked ,runLocked ,DatabasePoly ,createDatabase ,mkId ,getValueFromKey ,getIdFromKey ,getKeyValues ,getKeyValueFromId ,getKeyValuesFromId ,setMem ,setDisk ,modifyAllMem )whereimportData.Tuple.ExtraimportData.IORef.ExtraimportGeneral.Intern (Id ,Intern )importDevelopment.Shake.Classes importqualifiedData.HashMap.StrictasMapimportqualifiedGeneral.Intern asInternimportControl.Concurrent.ExtraimportControl.Monad.IO.ClassimportqualifiedGeneral.Ids asIdsimportControl.Monad.FailimportPreludenewtypeLocked a =Locked (IOa )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 ->IOb 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 -- | Invariant: The database does not have any cycles where a Key depends on itself.-- Everything is mutable. intern and status must form a bijection.-- There may be dangling Id's as a result of version changes.-- Lock is used to prevent any torn updatesdataDatabasePoly 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 )-- ^ Key |-> Id mapping,forall k v. DatabasePoly k v -> Ids (k, v)
status ::Ids.Ids (k ,v )-- ^ Id |-> (Key, Status) mapping,forall k v. DatabasePoly k v -> Id -> k -> v -> IO ()
journal ::Id ->k ->v ->IO()-- ^ Record all changes to status,forall k v. DatabasePoly k v -> v
vDefault ::v }createDatabase ::(Eqk ,Hashablek )=>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
newLockDatabasePoly k v -> IO (DatabasePoly k v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pureDatabase {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
.. }----------------------------------------------------------------------- SAFE READ-ONLYgetValueFromKey ::(Eqk ,Hashablek )=>DatabasePoly k v ->k ->IO(Maybev )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 =doIntern k
is <-IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORefIORef (Intern k)
intern casek -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is ofMaybe Id
Nothing->Maybe v -> IO (Maybe v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pureMaybe v
forall a. Maybe a
NothingJustId
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 -- Returns Nothing only if the Id was serialised previously but then the Id disappearedgetKeyValueFromId ::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.HashMapId (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 ::(Eqk ,Hashablek )=>DatabasePoly k v ->IO(k ->MaybeId )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
.. }=doIntern k
is <-IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORefIORef (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
flipk -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup Intern k
is ----------------------------------------------------------------------- MUTATING-- | Ensure that a Key has a given Id, creating an Id if there is not one alreadymkId ::(Eqk ,Hashablek )=>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
$doIntern k
is <-IORef (Intern k) -> IO (Intern k)
forall a. IORef a -> IO a
readIORefIORef (Intern k)
intern casek -> Intern k -> Maybe Id
forall a. (Eq a, Hashable a) => a -> Intern a -> Maybe Id
Intern.lookup k
k Intern k
is ofJustId
i ->Id -> IO Id
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pureId
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 -- make sure to write it into Status first to maintain Database invariantsIds (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
pureId
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