Make debouncer configurable (#409)

We have been experiencing a few flaky tests in DAML caused by our CLI
compiler losing diagnostics. The reason for that is the debouncer
which meant that messages got delayed and not send before the process
exited.

This PR makes the debouncer abstract and adds a noopDebouncer which
doesn’t do any debouncing. This is also what we use in the terminal
ghcide test thingy.

Author: cocreature

Diff for: exe/Main.hs

@@ -16,6 +16,7 @@ import Control.Monad.Extra
 import Control.Monad.IO.Class
 import Data.Default
 import System.Time.Extra
+import Development.IDE.Core.Debouncer
 import Development.IDE.Core.FileStore
 import Development.IDE.Core.OfInterest
 import Development.IDE.Core.Service
@@ -101,7 +102,8 @@ main = do
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     }
-            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs
+            debouncer <- newAsyncDebouncer
+            initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs
     else do
         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
@@ -136,7 +138,7 @@ main = do
         let options =
               (defaultIdeOptions $ return $ return . grab)
                     { optShakeProfiling = argsShakeProfiling }
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
         setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files

Diff for: ghcide.cabal

@@ -99,6 +99,7 @@ library
     include-dirs:
         include
     exposed-modules:
+        Development.IDE.Core.Debouncer
         Development.IDE.Core.FileStore
         Development.IDE.Core.OfInterest
         Development.IDE.Core.PositionMapping
@@ -121,7 +122,6 @@ library
         Development.IDE.Plugin.Completions
         Development.IDE.Plugin.CodeAction
     other-modules:
-        Development.IDE.Core.Debouncer
         Development.IDE.Core.Compile
         Development.IDE.Core.Preprocessor
         Development.IDE.Core.FileExists

Diff for: src/Development/IDE/Core/Debouncer.hs

@@ -3,8 +3,9 @@
 
 module Development.IDE.Core.Debouncer
     ( Debouncer
-    , newDebouncer
     , registerEvent
+    , newAsyncDebouncer
+    , noopDebouncer
     ) where
 
 import Control.Concurrent.Extra
@@ -22,25 +23,30 @@ import System.Time.Extra
 -- 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.
-newtype Debouncer k = Debouncer (Var (HashMap k (Async ())))
+--
+-- 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 { registerEvent :: Seconds -> k -> IO () -> IO () }
 
--- | Create a new empty debouncer.
-newDebouncer :: IO (Debouncer k)
-newDebouncer = do
-    m <- newVar Map.empty
-    pure $ Debouncer m
+-- | Debouncer used in the IDE that delays events as expected.
+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar 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.
-registerEvent :: (Eq k, Hashable k) => Debouncer k -> Seconds -> k -> IO () -> IO ()
-registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do
+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
     whenJust (Map.lookup k m) cancel
     a <- asyncWithUnmask $ \unmask -> unmask $ do
         sleep delay
         fire
         modifyVar_ d (pure . Map.delete k)
     pure $ Map.insert k a m
+
+-- | Debouncer used in the DAML CLI compiler that emits events immediately.
+noopDebouncer :: Debouncer k
+noopDebouncer = Debouncer $ \_ _ a -> a

Diff for: src/Development/IDE/Core/Service.hs

@@ -23,6 +23,7 @@ import           Control.Concurrent.Async
 import Data.Maybe
 import Development.IDE.Types.Options (IdeOptions(..))
 import Control.Monad
+import Development.IDE.Core.Debouncer
 import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules)
 import           Development.IDE.Core.FileExists (fileExistsRules)
 import           Development.IDE.Core.OfInterest
@@ -49,14 +50,16 @@ initialise :: LSP.ClientCapabilities
            -> IO LSP.LspId
            -> (LSP.FromServerMessage -> IO ())
            -> Logger
+           -> Debouncer LSP.NormalizedUri
            -> IdeOptions
            -> VFSHandle
            -> IO IdeState
-initialise caps mainRule getLspId toDiags logger options vfs =
+initialise caps mainRule getLspId toDiags logger debouncer options vfs =
     shakeOpen
         getLspId
         toDiags
         logger
+        debouncer
         (optShakeProfiling options)
         (optReportProgress options)
         shakeOptions

Diff for: src/Development/IDE/Core/Shake.hs

@@ -294,20 +294,20 @@ seqValue v b = case v of
 shakeOpen :: IO LSP.LspId
           -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
           -> Logger
+          -> Debouncer NormalizedUri
           -> Maybe FilePath
           -> IdeReportProgress
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
-shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
     inProgress <- newVar Map.empty
     shakeExtras <- do
         globals <- newVar HMap.empty
         state <- newVar HMap.empty
         diagnostics <- newVar mempty
         hiddenDiagnostics <- newVar mempty
         publishedDiagnostics <- newVar mempty
-        debouncer <- newDebouncer
         positionMapping <- newVar Map.empty
         pure ShakeExtras{..}
     (shakeDb, shakeClose) <-