Merge pull request #1018 from alanz/vscode-129-hanging-dispatcher

Remove unprotected 'head` in GhcMod codeactions

Author: alanz

hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs

@@ -22,6 +22,10 @@ data UriCacheResult = UriCacheSuccess UriCache
                     | UriCacheFailed
   deriving (Show)
 
+uriCacheState :: UriCacheResult -> String
+uriCacheState UriCacheFailed    = "UriCacheFailed"
+uriCacheState UriCacheSuccess{} = "UriCacheSuccess"
+
 data UriCache = UriCache
   { cachedInfo   :: !CachedInfo
   , cachedPsMod  :: !ParsedModule

hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

@@ -42,10 +42,9 @@ import qualified GhcMod.Utils  as GM
 import qualified GHC           as GHC
 
 import           Haskell.Ide.Engine.ArtifactMap
+import           Haskell.Ide.Engine.GhcModuleCache
 import           Haskell.Ide.Engine.MultiThreadState
 import           Haskell.Ide.Engine.PluginsIdeMonads
-import           Haskell.Ide.Engine.GhcModuleCache
-
 
 -- ---------------------------------------------------------------------
 
@@ -228,7 +227,7 @@ cacheModule uri modul = do
           _ -> UriCache defInfo pm Nothing mempty
 
       Right tm -> do
-        typm <- GM.unGmlT $ genTypeMap tm    
+        typm <- GM.unGmlT $ genTypeMap tm
         let info = CachedInfo (genLocMap tm) typm (genImportMap tm) (genDefMap tm) rfm return return
             pm = GHC.tm_parsed_module tm
         return $ UriCache info pm (Just tm) mempty
@@ -267,11 +266,12 @@ failModule fp = do
 runDeferredActions :: FilePath -> UriCacheResult -> IdeGhcM ()
 runDeferredActions uri res = do
       actions <- fmap (fromMaybe [] . Map.lookup uri) (requestQueue <$> readMTS)
-      liftToGhc $ forM_ actions (\a -> a res)
-
       -- remove queued actions
       modifyMTS $ \s -> s { requestQueue = Map.delete uri (requestQueue s) }
 
+      liftToGhc $ forM_ actions (\a -> a res)
+
+
 -- | Saves a module to the cache without clearing the associated cache data - use only if you are
 -- sure that the cached data associated with the module doesn't change
 cacheInfoNoClear :: (GM.MonadIO m, HasGhcModuleCache m)

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -298,7 +298,7 @@ type IdeDeferM = FreeT Defer IdeM
 
 type IdeM = ReaderT IdeEnv (MultiThreadState IdeState)
 
--- | Run an IdeM 
+-- | Run an IdeM
 runIdeM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a
 runIdeM plugins mlf stateVar f = do
   env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
@@ -338,13 +338,13 @@ instance MonadIde IdeM where
     case mlf of
       Just lf -> fromMaybe def <$> liftIO (Core.config lf)
       Nothing -> return def
-    
+
   getClientCapabilities = do
     mlf <- asks ideEnvLspFuncs
     case mlf of
       Just lf -> return (Core.clientCapabilities lf)
       Nothing -> return def
-  
+
   getPlugins = asks idePlugins
 
 instance MonadIde IdeGhcM where
@@ -360,7 +360,7 @@ instance MonadIde IdeDeferM where
   getConfig = lift getConfig
   getClientCapabilities = lift getClientCapabilities
   getPlugins = lift getPlugins
-      
+
 data IdeState = IdeState
   { moduleCache :: GhcModuleCache
   -- | A queue of requests to be performed once a module is loaded

src/Haskell/Ide/Engine/LSP/Reactor.hs

@@ -17,19 +17,21 @@ where
 
 import           Control.Monad.Reader
 import qualified Data.Map                      as Map
-import qualified Language.Haskell.LSP.Core     as Core
-import qualified Language.Haskell.LSP.Messages as J
-import qualified Language.Haskell.LSP.Types    as J
 import           Haskell.Ide.Engine.Compat
 import           Haskell.Ide.Engine.Config
 import           Haskell.Ide.Engine.PluginsIdeMonads
 import qualified Haskell.Ide.Engine.Scheduler  as Scheduler
 import           Haskell.Ide.Engine.Types
+import qualified Language.Haskell.LSP.Core     as Core
+import qualified Language.Haskell.LSP.Messages as J
+import qualified Language.Haskell.LSP.Types    as J
+
+-- ---------------------------------------------------------------------
 
 data REnv = REnv
   { scheduler         :: Scheduler.Scheduler R
   , lspFuncs          :: Core.LspFuncs Config
-  , reactorPidCache   :: Int
+  , reactorPidCache   :: Int -- TODO:AZ: do we need this? what is it for?
   , diagnosticSources :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
   , hoverProviders    :: [HoverProvider]
   , symbolProviders   :: [SymbolProvider]

src/Haskell/Ide/Engine/Plugin/GhcMod.hs

@@ -491,7 +491,10 @@ extractRedundantImport msg =
       && " is redundant" `T.isSuffixOf` firstLine
     then Just $ T.init $ T.tail $ T.dropWhileEnd (/= '’') $ T.dropWhile (/= '‘') firstLine
     else Nothing
-  where firstLine = head (T.lines msg)
+  where
+    firstLine = case T.lines msg of
+      [] -> ""
+      (l:_) -> l
 
 extractHoleSubstitutions :: T.Text -> Maybe (TypeDef, ValidSubstitutions, Bindings)
 extractHoleSubstitutions diag

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -16,7 +16,6 @@ module Haskell.Ide.Engine.Transport.LspStdio
   ) where
 
 import           Control.Concurrent
-import           Control.Concurrent.Async
 import           Control.Concurrent.STM.TChan
 import qualified Control.FoldDebounce as Debounce
 import qualified Control.Exception as E
@@ -142,7 +141,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
         let diagnosticsQueue tr = forever $ do
               inval <- liftIO $ atomically $ readTChan diagIn
               Debounce.send tr (coerce . Just $ MostRecent inval)
-        
+
         -- Debounce for (default) 350ms.
         debounceDuration <- diagnosticsDebounceDuration . fromMaybe def <$> Core.config lf
         tr <- Debounce.new
@@ -153,8 +152,8 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
         -- We launch the dispatcher after that so that the default cradle is
         -- recognized properly by ghc-mod
         _ <- forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf)
-                    `race_` reactorFunc
-                    `race_` diagnosticsQueue tr
+        _ <- forkIO   reactorFunc
+        _ <- forkIO $ diagnosticsQueue tr
         return Nothing
 
       diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
@@ -375,6 +374,7 @@ reactor inp diagIn = do
   let
     loop :: TrackingNumber -> R void
     loop tn = do
+      liftIO $ U.logs $ "****** reactor: top of loop"
       inval <- liftIO $ atomically $ readTChan inp
       liftIO $ U.logs $ "****** reactor: got message number:" ++ show tn