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

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

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

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

instance Show (DelayedAction a) where
  show :: DelayedAction a -> String
show DelayedAction a
d = String
"DelayedAction: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DelayedAction a -> String
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 = STM ActionQueue -> IO ActionQueue
forall a. STM a -> IO a
atomically (STM ActionQueue -> IO ActionQueue)
-> STM ActionQueue -> IO ActionQueue
forall a b. (a -> b) -> a -> b
$ do
  TQueue DelayedActionInternal
newActions <- STM (TQueue DelayedActionInternal)
forall a. STM (TQueue a)
newTQueue
  TVar (HashSet DelayedActionInternal)
inProgress <- HashSet DelayedActionInternal
-> STM (TVar (HashSet DelayedActionInternal))
forall a. a -> STM (TVar a)
newTVar HashSet DelayedActionInternal
forall a. Monoid a => a
mempty
  ActionQueue -> STM ActionQueue
forall (m :: * -> *) a. Monad m => a -> m a
return ActionQueue :: TQueue DelayedActionInternal
-> TVar (HashSet DelayedActionInternal) -> ActionQueue
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
..} = TQueue DelayedActionInternal -> DelayedActionInternal -> STM ()
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 <- TQueue DelayedActionInternal -> STM DelayedActionInternal
forall a. TQueue a -> STM a
readTQueue TQueue DelayedActionInternal
newActions
  TVar (HashSet DelayedActionInternal)
-> (HashSet DelayedActionInternal -> HashSet DelayedActionInternal)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet DelayedActionInternal)
inProgress (DelayedActionInternal
-> HashSet DelayedActionInternal -> HashSet DelayedActionInternal
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert DelayedActionInternal
x)
  DelayedActionInternal -> STM DelayedActionInternal
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 <- TQueue DelayedActionInternal -> STM [DelayedActionInternal]
forall a. TQueue a -> STM [a]
flushTQueue TQueue DelayedActionInternal
newActions
  (DelayedActionInternal -> STM ())
-> [DelayedActionInternal] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TQueue DelayedActionInternal -> DelayedActionInternal -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions) ((DelayedActionInternal -> Bool)
-> [DelayedActionInternal] -> [DelayedActionInternal]
forall a. (a -> Bool) -> [a] -> [a]
filter (DelayedActionInternal -> DelayedActionInternal -> Bool
forall a. Eq a => a -> a -> Bool
/= DelayedActionInternal
x) [DelayedActionInternal]
qq)
  TVar (HashSet DelayedActionInternal)
-> (HashSet DelayedActionInternal -> HashSet DelayedActionInternal)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet DelayedActionInternal)
inProgress (DelayedActionInternal
-> HashSet DelayedActionInternal -> HashSet DelayedActionInternal
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
  TVar (HashSet DelayedActionInternal)
-> (HashSet DelayedActionInternal -> HashSet DelayedActionInternal)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (HashSet DelayedActionInternal)
inProgress (DelayedActionInternal
-> HashSet DelayedActionInternal -> HashSet DelayedActionInternal
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 <- TQueue DelayedActionInternal -> STM [DelayedActionInternal]
forall a. TQueue a -> STM [a]
flushTQueue TQueue DelayedActionInternal
newActions
    (DelayedActionInternal -> STM ())
-> [DelayedActionInternal] -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TQueue DelayedActionInternal -> DelayedActionInternal -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions) [DelayedActionInternal]
backlog
    Int
m <- HashSet DelayedActionInternal -> Int
forall a. HashSet a -> Int
Set.size (HashSet DelayedActionInternal -> Int)
-> STM (HashSet DelayedActionInternal) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashSet DelayedActionInternal)
-> STM (HashSet DelayedActionInternal)
forall a. TVar a -> STM a
readTVar TVar (HashSet DelayedActionInternal)
inProgress
    Natural -> STM Natural
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> STM Natural) -> Natural -> STM Natural
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [DelayedActionInternal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DelayedActionInternal]
backlog Int -> Int -> Int
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
..} = HashSet DelayedActionInternal -> [DelayedActionInternal]
forall a. HashSet a -> [a]
Set.toList (HashSet DelayedActionInternal -> [DelayedActionInternal])
-> STM (HashSet DelayedActionInternal)
-> STM [DelayedActionInternal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (HashSet DelayedActionInternal)
-> STM (HashSet DelayedActionInternal)
forall a. TVar a -> STM a
readTVar TVar (HashSet DelayedActionInternal)
inProgress