-- 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.Extra import Control.Concurrent.Async import Control.Exception import Control.Monad.Extra import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map 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 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 ()))) -> IO ()) -> (HashMap k (Async ()) -> IO (HashMap k (Async ()))) -> IO () forall a b. (a -> b) -> a -> b $ \HashMap k (Async ()) m -> IO (HashMap k (Async ())) -> IO (HashMap k (Async ())) forall a. IO a -> IO a mask_ (IO (HashMap k (Async ())) -> IO (HashMap k (Async ()))) -> IO (HashMap k (Async ())) -> IO (HashMap k (Async ())) forall a b. (a -> b) -> a -> b $ do Maybe (Async ()) -> (Async () -> IO ()) -> IO () forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust (k -> HashMap k (Async ()) -> Maybe (Async ()) forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v Map.lookup k k HashMap k (Async ()) m) Async () -> IO () forall a. Async a -> IO () cancel HashMap k (Async ()) -> IO (HashMap k (Async ())) forall (f :: * -> *) a. Applicative f => a -> f a pure (HashMap k (Async ()) -> IO (HashMap k (Async ()))) -> HashMap k (Async ()) -> IO (HashMap k (Async ())) forall a b. (a -> b) -> a -> b $ 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 HashMap k (Async ()) m IO () fire asyncRegisterEvent Var (HashMap k (Async ())) d Seconds delay k k 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 ()))) -> IO ()) -> (HashMap k (Async ()) -> IO (HashMap k (Async ()))) -> IO () forall a b. (a -> b) -> a -> b $ \HashMap k (Async ()) m -> IO (HashMap k (Async ())) -> IO (HashMap k (Async ())) forall a. IO a -> IO a mask_ (IO (HashMap k (Async ())) -> IO (HashMap k (Async ()))) -> IO (HashMap k (Async ())) -> IO (HashMap k (Async ())) forall a b. (a -> b) -> a -> b $ do Maybe (Async ()) -> (Async () -> IO ()) -> IO () forall (m :: * -> *) a. Applicative m => Maybe a -> (a -> m ()) -> m () whenJust (k -> HashMap k (Async ()) -> Maybe (Async ()) forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v Map.lookup k k HashMap k (Async ()) m) Async () -> IO () forall a. Async a -> IO () cancel 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 (f :: * -> *) a. Applicative f => a -> f a pure (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) HashMap k (Async ()) -> IO (HashMap k (Async ())) forall (f :: * -> *) a. Applicative f => a -> f a pure (HashMap k (Async ()) -> IO (HashMap k (Async ()))) -> HashMap k (Async ()) -> IO (HashMap k (Async ())) forall a b. (a -> b) -> a -> b $ k -> Async () -> HashMap k (Async ()) -> HashMap k (Async ()) forall k v. (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v Map.insert k k Async () a HashMap k (Async ()) m -- | 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