-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

module Development.IDE.Core.Debouncer
    ( Debouncer
    , registerEvent
    , newAsyncDebouncer
    , noopDebouncer
    ) where

import           Control.Concurrent.Async
import           Control.Concurrent.STM.Stats (atomically, atomicallyNamed)
import           Control.Exception
import           Control.Monad                (join)
import           Data.Foldable                (traverse_)
import           Data.Hashable
import qualified Focus
import qualified StmContainers.Map            as STM
import           System.Time.Extra

-- | A debouncer can be used to avoid triggering many events
-- (e.g. diagnostics) for the same key (e.g. the same file)
-- within a short timeframe. This is accomplished
-- by delaying each event for a given time. If another event
-- is registered for the same key within that timeframe,
-- only the new event will fire.
--
-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable
-- debouncing in the DAML CLI compiler.
newtype Debouncer k = Debouncer { forall k. Debouncer k -> Seconds -> k -> IO () -> IO ()
registerEvent :: Seconds -> k -> IO () -> IO () }

-- | Debouncer used in the IDE that delays events as expected.
newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer :: forall k. (Eq k, Hashable k) => IO (Debouncer k)
newAsyncDebouncer = forall k. (Seconds -> k -> IO () -> IO ()) -> Debouncer k
Debouncer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
(Eq k, Hashable k) =>
Map k (Async ()) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall key value. IO (Map key value)
STM.newIO

-- | Register an event that will fire after the given delay if no other event
-- for the same key gets registered until then.
--
-- If there is a pending event for the same key, the pending event will be killed.
-- Events are run unmasked so it is up to the user of `registerEvent`
-- to mask if required.
asyncRegisterEvent :: (Eq k, Hashable k) => STM.Map k (Async ()) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent :: forall k.
(Eq k, Hashable k) =>
Map k (Async ()) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent Map k (Async ())
d Seconds
0 k
k IO ()
fire = do
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Maybe (Async ())
prev <- forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookupAndDelete k
k Map k (Async ())
d
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a. Async a -> IO ()
cancel Maybe (Async ())
prev
    IO ()
fire
asyncRegisterEvent Map k (Async ())
d Seconds
delay k
k IO ()
fire = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    Async ()
a <- forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ do
        Seconds -> IO ()
sleep Seconds
delay
        IO ()
fire
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall key value. Hashable key => key -> Map key value -> STM ()
STM.delete k
k Map k (Async ())
d
    Maybe (Async ())
prev <- forall a. String -> STM a -> IO a
atomicallyNamed String
"debouncer" forall a b. (a -> b) -> a -> b
$ forall key value result.
Hashable key =>
Focus value STM result -> key -> Map key value -> STM result
STM.focus (forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
Focus.lookup forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) a. Monad m => a -> Focus a m ()
Focus.insert Async ()
a) k
k Map k (Async ())
d
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a. Async a -> IO ()
cancel Maybe (Async ())
prev

-- | Debouncer used in the DAML CLI compiler that emits events immediately.
noopDebouncer :: Debouncer k
noopDebouncer :: forall k. Debouncer k
noopDebouncer = forall k. (Seconds -> k -> IO () -> IO ()) -> Debouncer k
Debouncer forall a b. (a -> b) -> a -> b
$ \Seconds
_ k
_ IO ()
a -> IO ()
a