migrate to classy concurrency

pepeiborra · pepeiborra · commit 545ed44672f6 · 2021-07-21T21:23:57.000+01:00
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -41,13 +41,15 @@ library
         binary,
         bytestring,
         case-insensitive,
+        concurrency,
         containers,
         data-default,
         deepseq,
         directory,
         dependent-map,
         dependent-sum,
         dlist,
+        exceptions,
         extra >= 1.7.4,
         fuzzy,
         filepath,
@@ -309,6 +311,28 @@ executable ghcide
         TypeApplications
         ViewPatterns
 
+test-suite concurrency-tests
+    type: exitcode-stdio-1.0
+    default-language: Haskell2010
+    build-depends:
+        async,
+        base,
+        concurrency,
+        dejafu,
+        exceptions,
+        extra,
+        filepath,
+        ghcide,
+        lsp-types,
+        tasty,
+        tasty-dejafu,
+        tasty-hunit,
+        text,
+        transformers
+    hs-source-dirs: test/conc
+    ghc-options: -threaded
+    main-is: Main.hs
+
 test-suite ghcide-tests
     type: exitcode-stdio-1.0
     default-language: Haskell2010
diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs
@@ -1,4 +1,11 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE PolyKinds              #-}
+{-# LANGUAGE QuantifiedConstraints  #-}
+{-# LANGUAGE RankNTypes             #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
 module Development.IDE.Core.ProgressReporting
   ( ProgressEvent(..)
   , ProgressReporting(..)
@@ -10,57 +17,63 @@ module Development.IDE.Core.ProgressReporting
   -- for tests
   , recordProgress
   , InProgress(..)
+  , MonadLSP(..)
+  , MonadProgress(..)
+  , MonadUnique(..)
   )
    where
 
-import           Control.Concurrent.Async
-import           Control.Concurrent.Strict
+import           Control.Concurrent.Classy
+import           Control.Concurrent.Classy.Async
+import           Control.Exception               (evaluate)
+import           Control.Monad.Catch             (bracket_, finally)
 import           Control.Monad.Extra
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class      (lift)
-import           Data.Foldable                  (for_)
-import           Data.Functor                   (($>))
-import qualified Data.HashMap.Strict            as HMap
-import qualified Data.Text                      as T
-import           Data.Tuple.Extra               (dupe)
-import           Data.Unique
-import           Development.IDE.GHC.Orphans    ()
-import           Development.IDE.Graph          hiding (ShakeValue)
+import           Control.Monad.Trans
+import           Data.Bifunctor                  (bimap)
+import           Data.Foldable                   (for_)
+import           Data.Functor                    (($>))
+import qualified Data.HashMap.Strict             as HMap
+import qualified Data.Text                       as T
+import           Data.Tuple.Extra                (dupe)
+import           Data.Unique                     (hashUnique)
+import qualified Data.Unique                     as IO
+import           Development.IDE.GHC.Orphans     ()
+import           Development.IDE.Graph           (Action, actionBracket)
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
-import qualified Language.LSP.Server            as LSP
+import qualified Language.LSP.Server             as LSP
 import           Language.LSP.Types
-import qualified Language.LSP.Types             as LSP
+import qualified Language.LSP.Types              as LSP
 import           System.Time.Extra
-import           UnliftIO.Exception             (bracket_, evaluate)
+import           UnliftIO                        (MonadUnliftIO)
 
 data ProgressEvent
     = KickStarted
     | KickCompleted
 
-data ProgressReporting  = ProgressReporting
-  { progressUpdate :: ProgressEvent -> IO ()
-  , inProgress     :: forall a. NormalizedFilePath -> Action a -> Action a
-  , progressStop   :: IO ()
+data ProgressReporting io m = ProgressReporting
+  { progressUpdate :: ProgressEvent -> io ()
+  , inProgress     :: forall a. NormalizedFilePath -> m a -> m a
+  , progressStop   :: io ()
   }
 
-noProgressReporting :: IO ProgressReporting
+noProgressReporting :: Monad m => m (ProgressReporting m n)
 noProgressReporting = return $ ProgressReporting
   { progressUpdate = const $ pure ()
   , inProgress = const id
   , progressStop   = pure ()
   }
 
 -- | State used in 'delayedProgressReporting'
-data State
+data State m
     = NotStarted
     | Stopped
-    | Running (Async ())
+    | Running (Async m ())
 
 -- | State transitions used in 'delayedProgressReporting'
 data Transition = Event ProgressEvent | StopProgress
 
-updateState :: IO () -> Transition -> State -> IO State
+updateState :: MonadConc m => m () -> Transition -> State m -> m (State m)
 updateState _      _                    Stopped     = pure Stopped
 updateState start (Event KickStarted)   NotStarted  = Running <$> async start
 updateState start (Event KickStarted)   (Running a) = cancel a >> Running <$> async start
@@ -91,40 +104,58 @@ recordProgress file shift InProgress{..} = case HMap.alterF alter file current o
   where
     alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x')
 
+class (forall n . Functor n => Functor (m n)) => MonadLSP c m | m -> c where
+    sendNotification :: forall n (meth :: Method 'FromServer 'Notification) . c n => SServerMethod meth -> MessageParams meth -> m n ()
+    sendRequest :: forall n (meth :: Method 'FromServer 'Request) . c n => SServerMethod meth -> MessageParams meth -> (Either () () -> n ()) -> m n ()
+
+instance MonadLSP MonadUnliftIO (LSP.LspT c) where
+    sendNotification m p = LSP.sendNotification m p
+    sendRequest m p k = void $ LSP.sendRequest m p (lift . k . bimap (const ()) (const ()))
+
+class MonadUnique m where newUnique :: m Int
+instance MonadUnique IO where newUnique = hashUnique <$> IO.newUnique
+
 -- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
 --   thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
 --   before the end of the grace period).
 delayedProgressReporting
-  :: Seconds  -- ^ Grace period before starting
+  :: forall c lsp m action
+  .  (c m, MonadProgress m action, MonadConc m, MonadUnique m, MonadLSP c lsp)
+  => Seconds  -- ^ Grace period before starting
   -> Seconds  -- ^ sampling delay
-  -> Maybe (LSP.LanguageContextEnv c)
   -> ProgressReportingStyle
-  -> IO ProgressReporting
-delayedProgressReporting before after lspEnv optProgressStyle = do
+  -> (lsp m () -> m ())
+  -> m (ProgressReporting m action)
+delayedProgressReporting before after optProgressStyle runLsp = do
     inProgressVar <- newMVar $ InProgress 0 0 mempty
     progressState <- newMVar NotStarted
     let progressUpdate event = updateStateVar $ Event event
-        progressStop   =  updateStateVar StopProgress
-        updateStateVar = modifyMVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar)
+        progressStop   = updateStateVar StopProgress
+        updateStateVar = modifyMVar_ progressState . updateState (lspShakeProgress inProgressVar)
 
-        inProgress :: NormalizedFilePath -> Action a -> Action a
+        -- inProgress :: NormalizedFilePath -> m a -> m a
         inProgress = withProgressVar inProgressVar
     return ProgressReporting{..}
     where
+        lspShakeProgress :: MVar m InProgress -> m ()
         lspShakeProgress inProgress = do
             -- first sleep a bit, so we only show progress messages if it's going to take
             -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
-            liftIO $ sleep before
-            u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique
-
-            b <- liftIO newEmptyMVar
-            void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate
-                LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . putMVar b
-            ready <- liftIO $ takeMVar b
-
-            for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
+            -- threadDelay (floor $ before * 1e9)
+            u <- ProgressTextToken . T.pack . show <$> newUnique
+
+            b <- newEmptyMVar
+            runLsp $ sendRequest LSP.SWindowWorkDoneProgressCreate
+                LSP.WorkDoneProgressCreateParams { _token = u } (putMVar b)
+            ready <- takeMVar b
+
+            for_ ready $ const $ uninterruptibleMask $ \unmask -> do
+                start u
+                -- stop u
+                unmask (loop u 0) `finally` stop u
+                -- bracket_ (start u) (stop u) (loop u 0)
             where
-                start id = LSP.sendNotification LSP.SProgress $
+                start id = runLsp $ sendNotification LSP.SProgress $
                     LSP.ProgressParams
                         { _token = id
                         , _value = LSP.Begin $ WorkDoneProgressBeginParams
@@ -134,22 +165,22 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
                           , _percentage = Nothing
                           }
                         }
-                stop id = LSP.sendNotification LSP.SProgress
+                stop id = runLsp $ sendNotification LSP.SProgress
                     LSP.ProgressParams
                         { _token = id
                         , _value = LSP.End WorkDoneProgressEndParams
                           { _message = Nothing
                           }
                         }
                 loop _ _ | optProgressStyle == NoProgress =
-                    forever $ liftIO $ threadDelay maxBound
+                    forever $ threadDelay maxBound
                 loop id prev = do
-                    InProgress{..} <- liftIO $ readMVar inProgress
-                    liftIO $ sleep after
+                    InProgress{..} <- readMVar inProgress
+                    threadDelay (floor $ after * 1e9)
                     if todo == 0 then loop id 0 else do
                         let next = 100 * fromIntegral done / fromIntegral todo
-                        when (next /= prev) $
-                          LSP.sendNotification LSP.SProgress $
+                        when (next /= prev) $ runLsp $
+                          sendNotification LSP.SProgress $
                           LSP.ProgressParams
                               { _token = id
                               , _value = LSP.Report $ case optProgressStyle of
@@ -167,12 +198,19 @@ delayedProgressReporting before after lspEnv optProgressStyle = do
                               }
                         loop id next
 
-        withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
+        withProgressVar var file = withProgressV var (f succ) (f pred)
             -- This functions are deliberately eta-expanded to avoid space leaks.
             -- Do not remove the eta-expansion without profiling a session with at
             -- least 1000 modifications.
             where
-              f shift = modifyMVar var $ evaluate . dupe . recordProgress file shift
+              f shift = recordProgress file shift
+
+class MonadProgress io m | m -> io where
+    withProgressV :: MVar io a -> (a->a) -> (a->a) -> m b -> m b
+
+instance MonadProgress IO Action where
+    withProgressV var succ pred =
+        actionBracket (modifyMVar var (evaluate.dupe.succ)) (const $ modifyMVar var (evaluate.dupe.pred)) . const
 
 mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()
 mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -107,7 +107,12 @@ import           Data.Vector                            (Vector)
 import qualified Data.Vector                            as Vector
 import           Development.IDE.Core.Debouncer
 import           Development.IDE.Core.PositionMapping
-import           Development.IDE.Core.ProgressReporting
+import           Development.IDE.Core.ProgressReporting (ProgressEvent (..),
+                                                         ProgressReporting (..),
+                                                         delayedProgressReporting,
+                                                         mRunLspT,
+                                                         mRunLspTCallback,
+                                                         noProgressReporting)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat             (NameCacheUpdater (..),
@@ -192,7 +197,7 @@ data ShakeExtras = ShakeExtras
     -- positions in a version of that document to positions in the latest version
     -- First mapping is delta from previous version and second one is an
     -- accumlation of all previous mappings.
-    ,progress :: ProgressReporting
+    ,progress :: ProgressReporting IO Action
     ,ideTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
     ,restartShakeSession
@@ -519,7 +524,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         progress <- do
             let (before, after) = if testing then (0,0.1) else (0.1,0.1)
             if reportProgress
-                then delayedProgressReporting before after lspEnv optProgressStyle
+                then delayedProgressReporting before after optProgressStyle (mRunLspT lspEnv)
                 else noProgressReporting
         actionQueue <- newQueue
 
diff --git a/ghcide/test/conc/Main.hs b/ghcide/test/conc/Main.hs
