{-# 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


-- | 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 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{..}


---------------------------------------------------------------------
-- 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{..} 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

-- 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{..} = 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


---------------------------------------------------------------------
-- 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{..} 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
            -- 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{..} 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