{-# 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.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 <- ReaderT SAction IO (IORef ResultDeps) -> Action (IORef ResultDeps)
forall a. ReaderT SAction IO a -> Action a
Action (ReaderT SAction IO (IORef ResultDeps)
 -> Action (IORef ResultDeps))
-> ReaderT SAction IO (IORef ResultDeps)
-> Action (IORef ResultDeps)
forall a b. (a -> b) -> a -> b
$ (SAction -> IORef ResultDeps)
-> ReaderT SAction IO (IORef ResultDeps)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks SAction -> IORef ResultDeps
actionDeps
    IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef ResultDeps -> (ResultDeps -> ResultDeps) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ResultDeps
ref ([Key] -> ResultDeps
AlwaysRerunDeps [] ResultDeps -> ResultDeps -> ResultDeps
forall a. Semigroup a => a -> a -> a
<>)

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

parallel :: [Action a] -> Action [a]
parallel :: [Action a] -> Action [a]
parallel [] = [a] -> Action [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parallel [Action a
x] = (a -> [a]) -> Action a -> Action [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) Action a
x
parallel [Action a]
xs = do
    SAction
a <- ReaderT SAction IO SAction -> Action SAction
forall a. ReaderT SAction IO a -> Action a
Action ReaderT SAction IO SAction
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ResultDeps
deps <- IO ResultDeps -> Action ResultDeps
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResultDeps -> Action ResultDeps)
-> IO ResultDeps -> Action ResultDeps
forall a b. (a -> b) -> a -> b
$ IORef ResultDeps -> IO ResultDeps
forall a. IORef a -> IO a
readIORef (IORef ResultDeps -> IO ResultDeps)
-> IORef ResultDeps -> IO ResultDeps
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
            IO [a] -> Action [a]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [a] -> Action [a]) -> IO [a] -> Action [a]
forall a b. (a -> b) -> a -> b
$ (Action a -> IO a) -> [Action a] -> IO [a]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (SAction -> Action a -> IO a
forall b. SAction -> Action b -> IO b
ignoreState SAction
a) [Action a]
xs
        ResultDeps
deps -> do
            ([ResultDeps]
newDeps, [a]
res) <- IO ([ResultDeps], [a]) -> Action ([ResultDeps], [a])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([ResultDeps], [a]) -> Action ([ResultDeps], [a]))
-> IO ([ResultDeps], [a]) -> Action ([ResultDeps], [a])
forall a b. (a -> b) -> a -> b
$ [(ResultDeps, a)] -> ([ResultDeps], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(ResultDeps, a)] -> ([ResultDeps], [a]))
-> IO [(ResultDeps, a)] -> IO ([ResultDeps], [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Action a -> IO (ResultDeps, a))
-> [Action a] -> IO [(ResultDeps, a)]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (SAction -> Action a -> IO (ResultDeps, a)
forall b. SAction -> Action b -> IO (ResultDeps, b)
usingState SAction
a) [Action a]
xs
            IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ IORef ResultDeps -> ResultDeps -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (SAction -> IORef ResultDeps
actionDeps SAction
a) (ResultDeps -> IO ()) -> ResultDeps -> IO ()
forall a b. (a -> b) -> a -> b
$ [ResultDeps] -> ResultDeps
forall a. Monoid a => [a] -> a
mconcat ([ResultDeps] -> ResultDeps) -> [ResultDeps] -> ResultDeps
forall a b. (a -> b) -> a -> b
$ ResultDeps
deps ResultDeps -> [ResultDeps] -> [ResultDeps]
forall a. a -> [a] -> [a]
: [ResultDeps]
newDeps
            [a] -> Action [a]
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 <- ResultDeps -> IO (IORef ResultDeps)
forall a. a -> IO (IORef a)
newIORef ResultDeps
forall a. Monoid a => a
mempty
            b
res <- ReaderT SAction IO b -> SAction -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action b -> ReaderT SAction IO b
forall a. Action a -> ReaderT SAction IO a
fromAction Action b
x) SAction
a{actionDeps :: IORef ResultDeps
actionDeps=IORef ResultDeps
ref}
            ResultDeps
deps <- IORef ResultDeps -> IO ResultDeps
forall a. IORef a -> IO a
readIORef IORef ResultDeps
ref
            (ResultDeps, b) -> IO (ResultDeps, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResultDeps
deps, b
res)

ignoreState :: SAction -> Action b -> IO b
ignoreState :: SAction -> Action b -> IO b
ignoreState SAction
a Action b
x = do
    IORef ResultDeps
ref <- ResultDeps -> IO (IORef ResultDeps)
forall a. a -> IO (IORef a)
newIORef ResultDeps
forall a. Monoid a => a
mempty
    ReaderT SAction IO b -> SAction -> IO b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action b -> ReaderT SAction IO b
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 :: Action a -> (Async a -> Action b) -> Action b
actionFork Action a
act Async a -> Action b
k = do
    SAction
a <- ReaderT SAction IO SAction -> Action SAction
forall a. ReaderT SAction IO a -> Action a
Action ReaderT SAction IO SAction
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ResultDeps
deps <- IO ResultDeps -> Action ResultDeps
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResultDeps -> Action ResultDeps)
-> IO ResultDeps -> Action ResultDeps
forall a b. (a -> b) -> a -> b
$ IORef ResultDeps -> IO ResultDeps
forall a. IORef a -> IO a
readIORef (IORef ResultDeps -> IO ResultDeps)
-> IORef ResultDeps -> IO ResultDeps
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] <- IO [b] -> Action [b]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [b] -> Action [b]) -> IO [b] -> Action [b]
forall a b. (a -> b) -> a -> b
$ IO a -> (Async a -> IO [b]) -> IO [b]
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (SAction -> Action a -> IO a
forall b. SAction -> Action b -> IO b
ignoreState SAction
a Action a
act) ((Async a -> IO [b]) -> IO [b]) -> (Async a -> IO [b]) -> IO [b]
forall a b. (a -> b) -> a -> b
$ \Async a
as -> Database -> [Action b] -> IO [b]
forall a. Database -> [Action a] -> IO [a]
runActions Database
db [Async a -> Action b
k Async a
as]
            b -> Action b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res
        ResultDeps
_ ->
            [Char] -> Action b
forall a. HasCallStack => [Char] -> a
error [Char]
"please help me"

isAsyncException :: SomeException -> Bool
isAsyncException :: SomeException -> Bool
isAsyncException SomeException
e
    | Just (AsyncCancelled
_ :: AsyncCancelled) <- SomeException -> Maybe AsyncCancelled
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
    | Just (AsyncException
_ :: AsyncException) <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True
    | Just (ExitCode
_ :: ExitCode) <- SomeException -> Maybe 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 :: Action a -> (e -> Action a) -> Action a
actionCatch Action a
a e -> Action a
b = do
    SAction
v <- ReaderT SAction IO SAction -> Action SAction
forall a. ReaderT SAction IO a -> Action a
Action ReaderT SAction IO SAction
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT SAction IO a -> Action a
forall a. ReaderT SAction IO a -> Action a
Action (ReaderT SAction IO a -> Action a)
-> ReaderT SAction IO a -> Action a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT SAction IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT SAction IO a) -> IO a -> ReaderT SAction IO a
forall a b. (a -> b) -> a -> b
$ (SomeException -> Maybe e) -> IO a -> (e -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
f (ReaderT SAction IO a -> SAction -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action a -> ReaderT SAction IO a
forall a. Action a -> ReaderT SAction IO a
fromAction Action a
a) SAction
v) (\e
x -> ReaderT SAction IO a -> SAction -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action a -> ReaderT SAction IO a
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 = Maybe a
forall a. Maybe a
Nothing
            | Bool
otherwise = SomeException -> Maybe a
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e

actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket :: 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 <- ReaderT SAction IO SAction -> Action SAction
forall a. ReaderT SAction IO a -> Action a
Action ReaderT SAction IO SAction
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT SAction IO c -> Action c
forall a. ReaderT SAction IO a -> Action a
Action (ReaderT SAction IO c -> Action c)
-> ReaderT SAction IO c -> Action c
forall a b. (a -> b) -> a -> b
$ IO c -> ReaderT SAction IO c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO c -> ReaderT SAction IO c) -> IO c -> ReaderT SAction IO c
forall a b. (a -> b) -> a -> b
$ IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO a
a a -> IO b
b (\a
x -> ReaderT SAction IO c -> SAction -> IO c
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action c -> ReaderT SAction IO c
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 :: Action a -> IO b -> Action a
actionFinally Action a
a IO b
b = do
    SAction
v <- ReaderT SAction IO SAction -> Action SAction
forall a. ReaderT SAction IO a -> Action a
Action ReaderT SAction IO SAction
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ReaderT SAction IO a -> Action a
forall a. ReaderT SAction IO a -> Action a
Action (ReaderT SAction IO a -> Action a)
-> ReaderT SAction IO a -> Action a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT SAction IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT SAction IO a) -> IO a -> ReaderT SAction IO a
forall a b. (a -> b) -> a -> b
$ IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
finally (ReaderT SAction IO a -> SAction -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action a -> ReaderT SAction IO a
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 :: key -> Action value
apply1 key
k = [value] -> value
forall a. [a] -> a
head ([value] -> value) -> Action [value] -> Action value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [key] -> Action [value]
forall key value.
(RuleResult key ~ value, ShakeValue key, Typeable value) =>
[key] -> Action [value]
apply [key
k]

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

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

runActions :: Database -> [Action a] -> IO [a]
runActions :: Database -> [Action a] -> IO [a]
runActions Database
db [Action a]
xs = do
    IORef ResultDeps
deps <- ResultDeps -> IO (IORef ResultDeps)
forall a. a -> IO (IORef a)
newIORef ResultDeps
forall a. Monoid a => a
mempty
    ReaderT SAction IO [a] -> SAction -> IO [a]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Action [a] -> ReaderT SAction IO [a]
forall a. Action a -> ReaderT SAction IO a
fromAction (Action [a] -> ReaderT SAction IO [a])
-> Action [a] -> ReaderT SAction IO [a]
forall a b. (a -> b) -> a -> b
$ [Action a] -> Action [a]
forall a. [Action a] -> Action [a]
parallel [Action a]
xs) (SAction -> IO [a]) -> SAction -> IO [a]
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
    IO [(Key, Int)] -> Action [(Key, Int)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Key, Int)] -> Action [(Key, Int)])
-> IO [(Key, Int)] -> Action [(Key, Int)]
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
    IO [(Key, Int)] -> Action [(Key, Int)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Key, Int)] -> Action [(Key, Int)])
-> IO [(Key, Int)] -> Action [(Key, Int)]
forall a b. (a -> b) -> a -> b
$ Database -> IO [(Key, Int)]
Development.IDE.Graph.Internal.Database.getKeysAndVisitAge Database
db