module Development.IDE.Types.Action
  ( DelayedAction (..),
    DelayedActionInternal,
    ActionQueue,
    newQueue,
    pushQueue,
    popQueue,
    doneQueue,
    peekInProgress,
  abortQueue,countQueue)
where

import           Control.Concurrent.STM
import           Data.Hashable                (Hashable (..))
import           Data.HashSet                 (HashSet)
import qualified Data.HashSet                 as Set
import           Data.Unique                  (Unique)
import           Development.IDE.Graph        (Action)
import           Development.IDE.Types.Logger
import           Numeric.Natural

data DelayedAction a = DelayedAction
  { forall a. DelayedAction a -> Maybe Unique
uniqueID       :: Maybe Unique,
    -- | Name we use for debugging
    forall a. DelayedAction a -> String
actionName     :: String,
    -- | Priority with which to log the action
    forall a. DelayedAction a -> Priority
actionPriority :: Priority,
    -- | The payload
    forall a. DelayedAction a -> Action a
getAction      :: Action a
  }
  deriving (forall a b. a -> DelayedAction b -> DelayedAction a
forall a b. (a -> b) -> DelayedAction a -> DelayedAction 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 -> DelayedAction b -> DelayedAction a
$c<$ :: forall a b. a -> DelayedAction b -> DelayedAction a
fmap :: forall a b. (a -> b) -> DelayedAction a -> DelayedAction b
$cfmap :: forall a b. (a -> b) -> DelayedAction a -> DelayedAction b
Functor)

type DelayedActionInternal = DelayedAction ()

instance Eq (DelayedAction a) where
  DelayedAction a
a == :: DelayedAction a -> DelayedAction a -> Bool
== DelayedAction a
b = forall a. DelayedAction a -> Maybe Unique
uniqueID DelayedAction a
a forall a. Eq a => a -> a -> Bool
== forall a. DelayedAction a -> Maybe Unique
uniqueID DelayedAction a
b

instance Hashable (DelayedAction a) where
  hashWithSalt :: Int -> DelayedAction a -> Int
hashWithSalt Int
s = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DelayedAction a -> Maybe Unique
uniqueID

instance Show (DelayedAction a) where
  show :: DelayedAction a -> String
show DelayedAction a
d = String
"DelayedAction: " forall a. [a] -> [a] -> [a]
++ forall a. DelayedAction a -> String
actionName DelayedAction a
d

------------------------------------------------------------------------------

data ActionQueue = ActionQueue
  { ActionQueue -> TQueue DelayedActionInternal
newActions :: TQueue DelayedActionInternal,
    ActionQueue -> TVar (HashSet DelayedActionInternal)
inProgress :: TVar (HashSet DelayedActionInternal)
  }

newQueue :: IO ActionQueue
newQueue :: IO ActionQueue
newQueue = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  TQueue DelayedActionInternal
newActions <- forall a. STM (TQueue a)
newTQueue
  TVar (HashSet DelayedActionInternal)
inProgress <- forall a. a -> STM (TVar a)
newTVar forall a. Monoid a => a
mempty
  forall (m :: * -> *) a. Monad m => a -> m a
return ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
..}

pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()
pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()
pushQueue DelayedActionInternal
act ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions DelayedActionInternal
act

-- | You must call 'doneQueue' to signal completion
popQueue :: ActionQueue -> STM DelayedActionInternal
popQueue :: ActionQueue -> STM DelayedActionInternal
popQueue ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = do
  DelayedActionInternal
x <- forall a. TQueue a -> STM a
readTQueue TQueue DelayedActionInternal
newActions
  forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet DelayedActionInternal)
inProgress (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert DelayedActionInternal
x)
  forall (m :: * -> *) a. Monad m => a -> m a
return DelayedActionInternal
x

-- | Completely remove an action from the queue
abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
abortQueue DelayedActionInternal
x ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = do
  [DelayedActionInternal]
qq <- forall a. TQueue a -> STM [a]
flushTQueue TQueue DelayedActionInternal
newActions
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions) (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= DelayedActionInternal
x) [DelayedActionInternal]
qq)
  forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashSet DelayedActionInternal)
inProgress (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete DelayedActionInternal
x)

-- | Mark an action as complete when called after 'popQueue'.
--   Has no effect otherwise
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
doneQueue DelayedActionInternal
x ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = do
  forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (HashSet DelayedActionInternal)
inProgress (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.delete DelayedActionInternal
x)

countQueue :: ActionQueue -> STM Natural
countQueue :: ActionQueue -> STM Natural
countQueue ActionQueue{TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = do
    [DelayedActionInternal]
backlog <- forall a. TQueue a -> STM [a]
flushTQueue TQueue DelayedActionInternal
newActions
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions) [DelayedActionInternal]
backlog
    Int
m <- forall a. HashSet a -> Int
Set.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashSet DelayedActionInternal)
inProgress
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [DelayedActionInternal]
backlog forall a. Num a => a -> a -> a
+ Int
m

peekInProgress :: ActionQueue -> STM [DelayedActionInternal]
peekInProgress :: ActionQueue -> STM [DelayedActionInternal]
peekInProgress ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: ActionQueue -> TQueue DelayedActionInternal
..} = forall a. HashSet a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar (HashSet DelayedActionInternal)
inProgress