{-# 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 (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 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 bijecttion.
--   There may be dangling Id's as a result of version changes.
--   Lock is used to prevent any torn updates
data DatabasePoly k v = Database
    {DatabasePoly k v -> Lock
lock :: Lock
    ,DatabasePoly k v -> IORef (Intern k)
intern :: IORef (Intern k) -- ^ Key |-> Id mapping
    ,DatabasePoly k v -> Ids (k, v)
status :: Ids.Ids (k, v) -- ^ Id |-> (Key, Status) mapping
    ,DatabasePoly k v -> Id -> k -> v -> IO ()
journal :: Id -> k -> v -> IO () -- ^ Record all changes to status
    ,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 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 (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{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
..}


---------------------------------------------------------------------
-- SAFE READ-ONLY

getValueFromKey :: (Eq k, Hashable k) => DatabasePoly k v -> k -> IO (Maybe v)
getValueFromKey :: 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 <- 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 (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 (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 disappeared
getKeyValueFromId :: DatabasePoly k v -> Id -> IO (Maybe (k, v))
getKeyValueFromId :: 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
..} = 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{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
..} = 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{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
..} = 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{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 <- 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


---------------------------------------------------------------------
-- MUTATING

-- | Ensure that a Key has a given Id, creating an Id if there is not one already
mkId :: (Eq k, Hashable k) => DatabasePoly k v -> k -> Locked Id
mkId :: 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 = 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 Id
i -> Id -> IO Id
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 (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 invariants
            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{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 = 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{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 = 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
$ \(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 :: 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