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


-- | 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 updates
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) -- ^ 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
    :: (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
..}


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

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

-- Returns Nothing only if the Id was serialised previously but then the Id disappeared
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


---------------------------------------------------------------------
-- 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 :: 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
            -- make sure to write it into Status first to maintain Database invariants
            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