-- 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.Strict
import           Control.Exception
import           Control.Monad             (join)
import           Data.Foldable             (traverse_)
import           Data.HashMap.Strict       (HashMap)
import qualified Data.HashMap.Strict       as Map
import           Data.Hashable
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 { 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 :: IO (Debouncer k)
newAsyncDebouncer = (Seconds -> k -> IO () -> IO ()) -> Debouncer k
forall k. (Seconds -> k -> IO () -> IO ()) -> Debouncer k
Debouncer ((Seconds -> k -> IO () -> IO ()) -> Debouncer k)
-> (Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ())
-> Var (HashMap k (Async ()))
-> Debouncer k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
forall k.
(Eq k, Hashable k) =>
Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent (Var (HashMap k (Async ())) -> Debouncer k)
-> IO (Var (HashMap k (Async ()))) -> IO (Debouncer k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap k (Async ()) -> IO (Var (HashMap k (Async ())))
forall a. a -> IO (Var a)
newVar HashMap k (Async ())
forall k v. HashMap k v
Map.empty

-- | 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) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent :: Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
asyncRegisterEvent Var (HashMap k (Async ()))
d Seconds
0 k
k IO ()
fire = do
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (HashMap k (Async ()))
-> (HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
-> IO (IO ())
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap k (Async ()))
d ((HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
 -> IO (IO ()))
-> (HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \HashMap k (Async ())
m -> do
        (IO ()
cancel, !HashMap k (Async ())
m') <- (IO (), HashMap k (Async ())) -> IO (IO (), HashMap k (Async ()))
forall a. a -> IO a
evaluate ((IO (), HashMap k (Async ())) -> IO (IO (), HashMap k (Async ())))
-> (IO (), HashMap k (Async ()))
-> IO (IO (), HashMap k (Async ()))
forall a b. (a -> b) -> a -> b
$ (Maybe (Async ()) -> (IO (), Maybe (Async ())))
-> k -> HashMap k (Async ()) -> (IO (), HashMap k (Async ()))
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
Map.alterF (\Maybe (Async ())
prev -> ((Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall a. Async a -> IO ()
cancel Maybe (Async ())
prev, Maybe (Async ())
forall a. Maybe a
Nothing)) k
k HashMap k (Async ())
m
        (HashMap k (Async ()), IO ()) -> IO (HashMap k (Async ()), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap k (Async ())
m', IO ()
cancel)
    IO ()
fire
asyncRegisterEvent Var (HashMap k (Async ()))
d Seconds
delay k
k IO ()
fire = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Async ()
a <- ((forall a. IO a -> IO a) -> IO ()) -> IO (Async ())
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO (Async ()))
-> ((forall a. IO a -> IO a) -> IO ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> IO () -> IO ()
forall a. IO a -> IO a
unmask (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Seconds -> IO ()
sleep Seconds
delay
        IO ()
fire
        Var (HashMap k (Async ()))
-> (HashMap k (Async ()) -> IO (HashMap k (Async ()))) -> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap k (Async ()))
d (HashMap k (Async ()) -> IO (HashMap k (Async ()))
forall a. a -> IO a
evaluate (HashMap k (Async ()) -> IO (HashMap k (Async ())))
-> (HashMap k (Async ()) -> HashMap k (Async ()))
-> HashMap k (Async ())
-> IO (HashMap k (Async ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> HashMap k (Async ()) -> HashMap k (Async ())
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete k
k)
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Var (HashMap k (Async ()))
-> (HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
-> IO (IO ())
forall a b. Var a -> (a -> IO (a, b)) -> IO b
modifyVar Var (HashMap k (Async ()))
d ((HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
 -> IO (IO ()))
-> (HashMap k (Async ()) -> IO (HashMap k (Async ()), IO ()))
-> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \HashMap k (Async ())
m -> do
        (IO ()
cancel, !HashMap k (Async ())
m') <- (IO (), HashMap k (Async ())) -> IO (IO (), HashMap k (Async ()))
forall a. a -> IO a
evaluate ((IO (), HashMap k (Async ())) -> IO (IO (), HashMap k (Async ())))
-> (IO (), HashMap k (Async ()))
-> IO (IO (), HashMap k (Async ()))
forall a b. (a -> b) -> a -> b
$ (Maybe (Async ()) -> (IO (), Maybe (Async ())))
-> k -> HashMap k (Async ()) -> (IO (), HashMap k (Async ()))
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
Map.alterF (\Maybe (Async ())
prev -> ((Async () -> IO ()) -> Maybe (Async ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Async () -> IO ()
forall a. Async a -> IO ()
cancel Maybe (Async ())
prev, Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
a)) k
k HashMap k (Async ())
m
        (HashMap k (Async ()), IO ()) -> IO (HashMap k (Async ()), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap k (Async ())
m', IO ()
cancel)

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