    {-# 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 -> 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 -> IO b
    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 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
        xs <- Ids (k, v) -> IO [(Id, (k, v))]
    forall a. Ids a -> IO [(Id, a)]
    Ids.toList Ids (k, v)
    status
        intern <- newIORef $ Intern.fromList [(k, i) | (i, (k,_)) <- xs]
        lock <- newLock
        pure Database{..}

    ---------------------------------------------------------------------
    -- 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 ()
    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 = do
        is <- IORef (Intern k) -> IO (Intern k)
    forall a. IORef a -> IO a
    readIORef IORef (Intern k)
    intern
        case Intern.lookup k is of
            Maybe Id
    Nothing -> Maybe v -> IO (Maybe v)
    forall a. a -> IO a
    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 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 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 ()
    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.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 ()
    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 :: (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 ()
    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
    ..} = do
        is <- IORef (Intern k) -> IO (Intern k)
    forall a. IORef a -> IO a
    readIORef IORef (Intern k)
    intern
        pure $ flip Intern.lookup 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 ()
    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
    $ do
        is <- IORef (Intern k) -> IO (Intern k)
    forall a. IORef a -> IO a
    readIORef IORef (Intern k)
    intern
        case Intern.lookup k is of
            Just Id
    i -> Id -> IO Id
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Id
    i
            Maybe Id
    Nothing -> do
                (is, 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 invariants
                Ids.insert status i (k, vDefault)
                writeIORef' intern is
                pure 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