Retry tests on SQLError

cabal.project

@@ -17,6 +17,11 @@ packages:
          ./plugins/hls-retrie-plugin
          ./plugins/hls-haddock-comments-plugin
          ./plugins/hls-splice-plugin
+source-repository-package
+    type: git
+    location: https://github.com/pepeiborra/lsp
+    tag: a7ef1f7f888298324ffb2e487a4276653e09a675
+    subdir: lsp
 tests: true
 
 package *

ghcide/exe/Arguments.hs

@@ -7,14 +7,11 @@ import           Development.IDE.Main (Command (..), commandP)
 import           Options.Applicative
 
 data Arguments = Arguments
-    {argsCwd                   :: Maybe FilePath
-    ,argsVersion               :: Bool
+    {argsVersion               :: Bool
     ,argsVSCodeExtensionSchema :: Bool
     ,argsDefaultConfig         :: Bool
     ,argsShakeProfiling        :: Maybe FilePath
     ,argsOTMemoryProfiling     :: Bool
-    ,argsTesting               :: Bool
-    ,argsDisableKick           :: Bool
     ,argsThreads               :: Int
     ,argsVerbose               :: Bool
     ,argsCommand               :: Command
@@ -29,14 +26,11 @@ getArguments = execParser opts
 
 arguments :: Parser Arguments
 arguments = Arguments
-      <$> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
-      <*> switch (long "version" <> help "Show ghcide and GHC versions")
+      <$> switch (long "version" <> help "Show ghcide and GHC versions")
       <*> switch (long "vscode-extension-schema" <> help "Print generic config schema for plugins (used in the package.json of haskell vscode extension)")
       <*> switch (long "generate-default-config" <> help "Print config supported by the server with default values")
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
-      <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
-      <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
       <*> switch (long "verbose" <> help "Include internal events in logging output")
       <*> (commandP <|> lspCommand <|> checkCommand)

ghcide/exe/Main.hs

@@ -8,7 +8,7 @@ module Main(main) where
 import           Arguments                         (Arguments (..),
                                                     getArguments)
 import           Control.Concurrent.Extra          (newLock, withLock)
-import           Control.Monad.Extra               (unless, when, whenJust)
+import           Control.Monad.Extra               (when)
 import qualified Data.Aeson.Encode.Pretty          as A
 import           Data.Default                      (Default (def))
 import           Data.List.Extra                   (upper)
@@ -19,20 +19,16 @@ import qualified Data.Text.Lazy.IO                 as LT
 import           Data.Version                      (showVersion)
 import           Development.GitRev                (gitHash)
 import           Development.IDE                   (Logger (Logger),
-                                                    Priority (Info), action)
-import           Development.IDE.Core.OfInterest   (kick)
-import           Development.IDE.Core.Rules        (mainRule)
+                                                    Priority (Info))
+import           Development.IDE.Graph             (ShakeOptions (shakeThreads))
 import qualified Development.IDE.Main              as Main
 import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde
-import qualified Development.IDE.Plugin.Test       as Test
 import           Development.IDE.Types.Options
-import           Development.IDE.Graph                 (ShakeOptions (shakeThreads))
 import           Ide.Plugin.Config                 (Config (checkParents, checkProject))
 import           Ide.Plugin.ConfigUtils            (pluginsToDefaultConfig,
                                                     pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                   (pluginDescToIdePlugins)
 import           Paths_ghcide                      (version)
-import qualified System.Directory.Extra            as IO
 import           System.Environment                (getExecutablePath)
 import           System.Exit                       (exitSuccess)
 import           System.IO                         (hPutStrLn, stderr)
@@ -68,8 +64,6 @@ main = do
       LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig hlsPlugins
       exitSuccess
 
-    whenJust argsCwd IO.setCurrentDirectory
-
     -- lock to avoid overlapping output on stdout
     lock <- newLock
     let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $
@@ -78,32 +72,12 @@ main = do
 
     Main.defaultMain def
         {Main.argCommand = argsCommand
-
         ,Main.argsLogger = pure logger
-
-        ,Main.argsRules = do
-            -- install the main and ghcide-plugin rules
-            mainRule
-            -- install the kick action, which triggers a typecheck on every
-            -- Shake database restart, i.e. on every user edit.
-            unless argsDisableKick $
-                action kick
-
-        ,Main.argsHlsPlugins =
-            pluginDescToIdePlugins $
-            GhcIde.descriptors
-            ++ [Test.blockCommandDescriptor "block-command" | argsTesting]
-
-        ,Main.argsGhcidePlugin = if argsTesting
-            then Test.plugin
-            else mempty
-
         ,Main.argsIdeOptions = \config  sessionLoader ->
             let defOptions = defaultIdeOptions sessionLoader
             in defOptions
                 { optShakeProfiling = argsShakeProfiling
                 , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                , optTesting = IdeTesting argsTesting
                 , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config

ghcide/ghcide.cabal

@@ -188,6 +188,7 @@ library
         Development.IDE.Plugin.CodeAction.ExactPrint
         Development.IDE.Plugin.HLS
         Development.IDE.Plugin.HLS.GhcIde
+        Development.IDE.Plugin.LspLogger
         Development.IDE.Plugin.Test
         Development.IDE.Plugin.TypeLenses
 
@@ -348,6 +349,7 @@ test-suite ghcide-tests
         hls-plugin-api,
         network-uri,
         lens,
+        lsp,
         lsp-test == 0.14.0.0,
         optparse-applicative,
         process,
@@ -359,6 +361,7 @@ test-suite ghcide-tests
         safe-exceptions,
         shake,
         hls-graph,
+        sqlite-simple,
         tasty,
         tasty-expected-failure,
         tasty-hunit,

ghcide/session-loader/Development/IDE/Session.hs

@@ -48,6 +48,7 @@ import           Development.IDE.GHC.Compat           hiding (Target,
                                                        TargetFile, TargetModule)
 import qualified Development.IDE.GHC.Compat           as GHC
 import           Development.IDE.GHC.Util
+import           Development.IDE.Graph                (Action)
 import           Development.IDE.Session.VersionCheck
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Exports
@@ -56,7 +57,6 @@ import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Options
-import           Development.IDE.Graph                    (Action)
 import           GHC.Check
 import qualified HIE.Bios                             as HieBios
 import           HIE.Bios.Environment                 hiding (getCacheDir)
@@ -85,12 +85,12 @@ import           Control.Concurrent.STM               (atomically)
 import           Control.Concurrent.STM.TQueue
 import qualified Data.HashSet                         as Set
 import           Database.SQLite.Simple
+import           GHC.LanguageExtensions               (Extension (EmptyCase))
 import           HIE.Bios.Cradle                      (yamlConfig)
 import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
 import           Maybes                               (MaybeT (runMaybeT))
-import           GHC.LanguageExtensions               (Extension(EmptyCase))
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -107,7 +107,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   --   or 'Nothing' to respect the cradle setting
   , getCacheDirs        :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
-  , getInitialGhcLibDir :: IO (Maybe LibDir)
+  , getInitialGhcLibDir :: Logger -> IO (Maybe LibDir)
   , fakeUid             :: InstalledUnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
@@ -124,26 +124,26 @@ instance Default SessionLoadingOptions where
         ,fakeUid = toInstalledUnitId (stringToUnitId "main")
         }
 
-getInitialGhcLibDirDefault :: IO (Maybe LibDir)
-getInitialGhcLibDirDefault = do
+getInitialGhcLibDirDefault :: Logger -> IO (Maybe LibDir)
+getInitialGhcLibDirDefault logger = do
   dir <- IO.getCurrentDirectory
   hieYaml <- runMaybeT $ yamlConfig dir
   cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml
-  hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
+  logDebug logger $ "setInitialDynFlags cradle: " <> T.pack(show cradle)
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
       CradleSuccess libdir -> pure $ Just $ LibDir libdir
       CradleFail err -> do
-        hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)
+        logError logger $ "Couldn't load cradle for libdir: " <> T.pack(show (err,dir,hieYaml,cradle))
         pure Nothing
       CradleNone -> do
-        hPutStrLn stderr "Couldn't load cradle (CradleNone)"
+        logError logger "Couldn't load cradle (CradleNone)"
         pure Nothing
 
 -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)
-setInitialDynFlags SessionLoadingOptions{..} = do
-  libdir <- getInitialGhcLibDir
+setInitialDynFlags :: Logger -> SessionLoadingOptions -> IO (Maybe LibDir)
+setInitialDynFlags logger SessionLoadingOptions{..} = do
+  libdir <- getInitialGhcLibDir logger
   dynFlags <- mapM dynFlagsForPrinting libdir
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
@@ -152,8 +152,8 @@ setInitialDynFlags SessionLoadingOptions{..} = do
 -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
 -- by a worker thread using a dedicated database connection.
 -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
-runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
-runWithDb fp k = do
+runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
+runWithDb logger fp k = do
   -- Delete the database if it has an incompatible schema version
   withHieDb fp (const $ pure ())
     `catch` \IncompatibleSchemaVersion{} -> removeFile fp
@@ -171,9 +171,9 @@ runWithDb fp k = do
         k <- atomically $ readTQueue chan
         k db
           `catch` \e@SQLError{} -> do
-            hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e
+            logWarning logger $ "SQLite error in worker, ignoring: " <> T.pack(show e)
           `catchAny` \e -> do
-            hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e
+            logWarning logger $ "Uncaught error in database worker, ignoring: " <> T.pack(show e)
 
 
 getHieDbLoc :: FilePath -> IO FilePath
@@ -346,8 +346,8 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
             res <- loadDLL hscEnv "libm.so.6"
             case res of
               Nothing -> pure ()
-              Just err -> hPutStrLn stderr $
-                "Error dynamically loading libm.so.6:\n" <> err
+              Just err -> logError logger $
+                "Error dynamically loading libm.so.6:\n" <> T.pack err
 
           -- Make a map from unit-id to DynFlags, this is used when trying to
           -- resolve imports. (especially PackageImports)
@@ -409,7 +409,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
                          <> " (for " <> T.pack lfp <> ")"
            eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
-              cradleToOptsAndLibDir cradle cfp
+              cradleToOptsAndLibDir logger cradle cfp
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of
@@ -479,12 +479,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 -- This then builds dependencies or whatever based on the cradle, gets the
 -- GHC options/dynflags needed for the session and the GHC library directory
 
-cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
+cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
-cradleToOptsAndLibDir cradle file = do
+cradleToOptsAndLibDir logger cradle file = do
     -- Start off by getting the session options
     let showLine s = hPutStrLn stderr ("> " ++ s)
-    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
+    logDebug logger $ "Output from setting up the cradle " <> T.pack (show cradle)
     cradleRes <- runCradle (cradleOptsProg cradle) showLine file
     case cradleRes of
         CradleSuccess r -> do

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -134,15 +134,17 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
             ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan
 
             let initConfig = parseConfiguration params
-            logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
+                l = ideLogger ide
+            logInfo l $ T.pack $ "Registering ide configuration: " <> show initConfig
             registerIdeConfiguration (shakeExtras ide) initConfig
 
             let handleServerException (Left e) = do
                     logError (ideLogger ide) $
                         T.pack $ "Fatal error in server thread: " <> show e
                     exitClientMsg
+                    throwIO e
                 handleServerException _ = pure ()
-            _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do
+            _ <- flip forkFinally handleServerException $ runWithDb l dbLoc $ \hiedb hieChan -> do
               putMVar dbMVar (hiedb,hieChan)
               forever $ do
                 msg <- readChan clientMsgChan

ghcide/src/Development/IDE/Main.hs

@@ -56,7 +56,7 @@ import           Development.IDE.Session               (SessionLoadingOptions,
                                                         setInitialDynFlags)
 import           Development.IDE.Types.Location        (NormalizedUri,
                                                         toNormalizedFilePath')
-import           Development.IDE.Types.Logger          (Logger (Logger))
+import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Options         (IdeGhcSession,
                                                         IdeOptions (optCheckParents, optCheckProject, optReportProgress),
                                                         clientSupportsProgress,
@@ -198,11 +198,11 @@ defaultMain Arguments{..} = do
     case argCommand of
         LSP -> do
             t <- offsetTime
-            hPutStrLn stderr "Starting LSP server..."
-            hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
+            logInfo logger "Starting LSP server..."
+            logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
             runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
                 t <- t
-                hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
+                logInfo logger $ "Started LSP server in " <> T.pack(showDuration t)
 
                 dir <- IO.getCurrentDirectory
 
@@ -211,8 +211,8 @@ defaultMain Arguments{..} = do
                 -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
                 -- before calling this function
                 _mlibdir <-
-                    setInitialDynFlags argsSessionLoadingOptions
-                        `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
+                    setInitialDynFlags logger argsSessionLoadingOptions
+                        `catchAny` (\e -> (logError logger $ "setInitialDynFlags: " <> T.pack(displayException e)) >> pure Nothing)
 
                 sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath
                 config <- LSP.runLspT env LSP.getConfig
@@ -233,7 +233,7 @@ defaultMain Arguments{..} = do
         Check argFiles -> do
           dir <- IO.getCurrentDirectory
           dbLoc <- getHieDbLoc dir
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
             hSetEncoding stdout utf8
             hSetEncoding stderr utf8
@@ -295,13 +295,13 @@ defaultMain Arguments{..} = do
         Db dir opts cmd -> do
             dbLoc <- getHieDbLoc dir
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-            mlibdir <- setInitialDynFlags def
+            mlibdir <- setInitialDynFlags logger def
             case mlibdir of
                 Nothing     -> exitWith $ ExitFailure 1
                 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
         Custom projectRoot (IdeCommand c) -> do
           dbLoc <- getHieDbLoc projectRoot
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             vfs <- makeVFSHandle
             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
             let options =

ghcide/src/Development/IDE/Plugin/LspLogger.hs

@@ -0,0 +1,25 @@
+module Development.IDE.Plugin.LspLogger (lspLogger) where
+
+import           Control.Monad.Extra          (whenJust)
+import           Control.Monad.IO.Class
+import qualified Data.Aeson                   as A
+import           Data.IORef
+import           Development.IDE.Types.Logger
+import           Ide.Types
+import qualified Language.LSP.Server          as LSP
+import           Language.LSP.Types
+
+-- | A logger that sends messages to the LSP client
+lspLogger :: IO (Logger, PluginDescriptor a)
+lspLogger = do
+    lspEnvRef <- newIORef Nothing
+    let plugin = (defaultPluginDescriptor "lspLogging"){
+            pluginNotificationHandlers =
+                mkPluginNotificationHandler SInitialized $ \_ _ _ ->
+                    liftIO $ readIORef lspEnvRef >>= writeIORef lspEnvRef
+        }
+        logger = Logger $ \_p msg -> do
+            env <- readIORef lspEnvRef
+            whenJust env $ \env ->
+                LSP.runLspT env (LSP.sendNotification (SCustomMethod "ghcide/log") (A.String msg))
+    return (logger, plugin)