{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Development.IDE.Graph.Internal.Action
( ShakeValue
, actionFork
, actionBracket
, actionCatch
, actionFinally
, alwaysRerun
, apply1
, apply
, applyWithoutDependency
, parallel
, reschedule
, runActions
, Development.IDE.Graph.Internal.Action.getDirtySet
, getKeysAndVisitedAge
) where

import           Control.Concurrent.Async
import           Control.Exception
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Reader
import           Data.Foldable                           (toList)
import           Data.Functor.Identity
import           Data.IORef
import           Development.IDE.Graph.Classes
import           Development.IDE.Graph.Internal.Database
import           Development.IDE.Graph.Internal.Rules    (RuleResult)
import           Development.IDE.Graph.Internal.Types
import           System.Exit

type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)

-- | Always rerun this rule when dirty, regardless of the dependencies.
alwaysRerun :: Action ()
alwaysRerun :: Action ()
alwaysRerun = do
    IORef ResultDeps
ref <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> IORef ResultDeps
actionDeps
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ResultDeps
ref ([Key] -> ResultDeps
AlwaysRerunDeps [] forall a. Semigroup a => a -> a -> a
<>)

-- No-op for now
reschedule :: Double -> Action ()
reschedule :: Double -> Action ()
reschedule Double
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

parallel :: [Action a] -> Action [a]
parallel :: forall a. [Action a] -> Action [a]
parallel [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parallel [Action a
x] = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) Action a
x
parallel [Action a]
xs = do
    SAction
a <- forall a. ReaderT SAction IO a -> Action a
Action forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ResultDeps
deps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ SAction -> IORef ResultDeps
actionDeps SAction
a
    case ResultDeps
deps of
        ResultDeps
UnknownDeps ->
            -- if we are already in the rerun mode, nothing we do is going to impact our state
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (forall b. SAction -> Action b -> IO b
ignoreState SAction
a) [Action a]
xs
        ResultDeps
deps -> do
            ([ResultDeps]
newDeps, [a]
res) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (forall {b}. SAction -> Action b -> IO (ResultDeps, b)
usingState SAction
a) [Action a]
xs
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (SAction -> IORef ResultDeps
actionDeps SAction
a) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ ResultDeps
deps forall a. a -> [a] -> [a]
: [ResultDeps]
newDeps
            forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
res
    where
        usingState :: SAction -> Action b -> IO (ResultDeps, b)
usingState SAction
a Action b
x = do
            IORef ResultDeps
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
            b
res <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction Action b
x) SAction
a{actionDeps :: IORef ResultDeps
actionDeps=IORef ResultDeps
ref}
            ResultDeps
deps <- forall a. IORef a -> IO a
readIORef IORef ResultDeps
ref
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResultDeps
deps, b
res)

ignoreState :: SAction -> Action b -> IO b
ignoreState :: forall b. SAction -> Action b -> IO b
ignoreState SAction
a Action b
x = do
    IORef ResultDeps
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction Action b
x) SAction
a{actionDeps :: IORef ResultDeps
actionDeps=IORef ResultDeps
ref}

actionFork :: Action a -> (Async a -> Action b) -> Action b
actionFork :: forall a b. Action a -> (Async a -> Action b) -> Action b
actionFork Action a
act Async a -> Action b
k = do
    SAction
a <- forall a. ReaderT SAction IO a -> Action a
Action forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ResultDeps
deps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ SAction -> IORef ResultDeps
actionDeps SAction
a
    let db :: Database
db = SAction -> Database
actionDatabase SAction
a
    case ResultDeps
deps of
        ResultDeps
UnknownDeps -> do
            -- if we are already in the rerun mode, nothing we do is going to impact our state
            [b
res] <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (forall b. SAction -> Action b -> IO b
ignoreState SAction
a Action a
act) forall a b. (a -> b) -> a -> b
$ \Async a
as -> forall a. Database -> [Action a] -> IO [a]
runActions Database
db [Async a -> Action b
k Async a
as]
            forall (m :: * -> *) a. Monad m => a -> m a
return b
res
        ResultDeps
_ ->
            forall a. HasCallStack => [Char] -> a
error [Char]
"please help me"

isAsyncException :: SomeException -> Bool
isAsyncException :: SomeException -> Bool
isAsyncException SomeException
e
    | Just (AsyncCancelled
_ :: AsyncCancelled) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
    | Just (AsyncException
_ :: AsyncException) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
    | Just (ExitCode
_ :: ExitCode) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
    | Bool
otherwise = Bool
False


actionCatch :: Exception e => Action a -> (e -> Action a) -> Action a
actionCatch :: forall e a. Exception e => Action a -> (e -> Action a) -> Action a
actionCatch Action a
a e -> Action a
b = do
    SAction
v <- forall a. ReaderT SAction IO a -> Action a
Action forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust forall e. Exception e => SomeException -> Maybe e
f (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction Action a
a) SAction
v) (\e
x -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction (e -> Action a
b e
x)) SAction
v)
    where
        -- Catch only catches exceptions that were caused by this code, not those that
        -- are a result of program termination
        f :: SomeException -> Maybe a
f SomeException
e | SomeException -> Bool
isAsyncException SomeException
e = forall a. Maybe a
Nothing
            | Bool
otherwise = forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e

actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket :: forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket IO a
a a -> IO b
b a -> Action c
c = do
    SAction
v <- forall a. ReaderT SAction IO a -> Action a
Action forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO a
a a -> IO b
b (\a
x -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction (a -> Action c
c a
x)) SAction
v)

actionFinally :: Action a -> IO b -> Action a
actionFinally :: forall a b. Action a -> IO b -> Action a
actionFinally Action a
a IO b
b = do
    SAction
v <- forall a. ReaderT SAction IO a -> Action a
Action forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO a
finally (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction Action a
a) SAction
v) IO b
b

apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
apply1 :: forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
key -> Action value
apply1 key
k = forall a. Identity a -> a
runIdentity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
apply (forall a. a -> Identity a
Identity key
k)

apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
apply :: forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
apply f key
ks = do
    Database
db <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> Database
actionDatabase
    Stack
stack <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> Stack
actionStack
    (f Key
is, f value
vs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, Typeable key, Show key,
 Hashable key, Eq key, Typeable value) =>
Database -> Stack -> f key -> IO (f Key, f value)
build Database
db Stack
stack f key
ks
    IORef ResultDeps
ref <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> IORef ResultDeps
actionDeps
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ResultDeps
ref ([Key] -> ResultDeps
ResultDeps (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Key
is) forall a. Semigroup a => a -> a -> a
<>)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure f value
vs

-- | Evaluate a list of keys without recording any dependencies.
applyWithoutDependency :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
applyWithoutDependency :: forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, ShakeValue key,
 Typeable value) =>
f key -> Action (f value)
applyWithoutDependency f key
ks = do
    Database
db <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> Database
actionDatabase
    Stack
stack <- forall a. ReaderT SAction IO a -> Action a
Action forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> Stack
actionStack
    (f Key
_, f value
vs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) key value.
(Traversable f, RuleResult key ~ value, Typeable key, Show key,
 Hashable key, Eq key, Typeable value) =>
Database -> Stack -> f key -> IO (f Key, f value)
build Database
db Stack
stack f key
ks
    forall (f :: * -> *) a. Applicative f => a -> f a
pure f value
vs

runActions :: Database -> [Action a] -> IO [a]
runActions :: forall a. Database -> [Action a] -> IO [a]
runActions Database
db [Action a]
xs = do
    IORef ResultDeps
deps <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
    forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Action a -> ReaderT SAction IO a
fromAction forall a b. (a -> b) -> a -> b
$ forall a. [Action a] -> Action [a]
parallel [Action a]
xs) forall a b. (a -> b) -> a -> b
$ Database -> IORef ResultDeps -> Stack -> SAction
SAction Database
db IORef ResultDeps
deps Stack
emptyStack

-- | Returns the set of dirty keys annotated with their age (in # of builds)
getDirtySet  :: Action [(Key, Int)]
getDirtySet :: Action [(Key, Int)]
getDirtySet = do
    Database
db <- Action Database
getDatabase
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Database -> IO [(Key, Int)]
Development.IDE.Graph.Internal.Database.getDirtySet Database
db

getKeysAndVisitedAge :: Action [(Key, Int)]
getKeysAndVisitedAge :: Action [(Key, Int)]
getKeysAndVisitedAge = do
    Database
db <- Action Database
getDatabase
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Database -> IO [(Key, Int)]
Development.IDE.Graph.Internal.Database.getKeysAndVisitAge Database
db