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 Ide.Logger
import Numeric.Natural
data DelayedAction a = DelayedAction
{ forall a. DelayedAction a -> Maybe Unique
uniqueID :: Maybe Unique,
forall a. DelayedAction a -> String
actionName :: String,
forall a. DelayedAction a -> Priority
actionPriority :: Priority,
forall a. DelayedAction a -> Action a
getAction :: Action a
}
deriving ((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
$cfmap :: forall a b. (a -> b) -> DelayedAction a -> DelayedAction b
fmap :: forall a b. (a -> b) -> DelayedAction a -> DelayedAction b
$c<$ :: forall a b. a -> DelayedAction b -> DelayedAction a
<$ :: forall a b. a -> DelayedAction b -> DelayedAction a
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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
..}
pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()
pushQueue :: DelayedActionInternal -> ActionQueue -> STM ()
pushQueue DelayedActionInternal
act ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet DelayedActionInternal)
..} = TQueue DelayedActionInternal -> DelayedActionInternal -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue DelayedActionInternal
newActions DelayedActionInternal
act
popQueue :: ActionQueue -> STM DelayedActionInternal
popQueue :: ActionQueue -> STM DelayedActionInternal
popQueue ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet 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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return DelayedActionInternal
x
abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
abortQueue DelayedActionInternal
x ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet 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)
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
doneQueue DelayedActionInternal
x ActionQueue {TVar (HashSet DelayedActionInternal)
TQueue DelayedActionInternal
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet 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
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet 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 a. a -> STM a
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 a. [a] -> 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
newActions :: ActionQueue -> TQueue DelayedActionInternal
inProgress :: ActionQueue -> TVar (HashSet DelayedActionInternal)
newActions :: TQueue DelayedActionInternal
inProgress :: TVar (HashSet 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