References via hiedb (#704)

* Integrate hiedb

1. Add 'indexHieFile' and rule 'GetModIfaceFromDiskAndIndex' to maintain
   database integrity
   - 'writeHieFile' -> 'writeAndIndexHieFile'
2. References fromm database
3. Use db for go to definition
   - Return multiple definitions for things defined in boot files
   - More robust definitions for multi-component
4. Add persistent stale rules to answer queries immedidately on startup
   - Setup `unsafeGlobalDynFlags` on startup
5. Add hiedb command line to ghcide and hls

Co-authored-by: Pepe Iborra <[email protected]>
Co-authored-by: Peter Wicks Stringfield <[email protected]>

* Update ghcide/bench/lib/Experiments.hs

Co-authored-by: Pepe Iborra <[email protected]>

* Clear deleted files from hiedb

* make garbage collection async

* bump hiedb

Co-authored-by: Pepe Iborra <[email protected]>
Co-authored-by: Peter Wicks Stringfield <[email protected]>

Author: 3 people

cabal.project

@@ -30,7 +30,7 @@ package ghcide
 
 write-ghc-environment-files: never
 
-index-state: 2021-01-17T17:47:48Z
+index-state: 2021-01-28T17:47:48Z
 
 allow-newer:
 	active:base,

exe/Wrapper.hs

@@ -43,20 +43,24 @@ main = do
       VersionMode PrintNumericVersion ->
           putStrLn haskellLanguageServerNumericVersion
 
-      LspMode lspArgs ->
-          launchHaskellLanguageServer lspArgs
+      _ -> launchHaskellLanguageServer args
 
-launchHaskellLanguageServer :: LspArguments -> IO ()
-launchHaskellLanguageServer LspArguments{..} = do
-  whenJust argsCwd setCurrentDirectory
+launchHaskellLanguageServer :: Arguments -> IO ()
+launchHaskellLanguageServer parsedArgs = do
+  case parsedArgs of
+    LspMode LspArguments{..} -> whenJust argsCwd setCurrentDirectory
+    _ -> pure ()
 
   d <- getCurrentDirectory
 
   -- Get the cabal directory from the cradle
   cradle <- findLocalCradle (d </> "a")
   setCurrentDirectory $ cradleRootDir cradle
 
-  when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
+  case parsedArgs of
+    LspMode LspArguments{..} ->
+      when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess
+    _ -> pure ()
 
   progName <- getProgName
   hPutStrLn stderr $ "Run entered for haskell-language-server-wrapper(" ++ progName ++ ") "

ghcide/.hlint.yaml

@@ -88,6 +88,7 @@
     - Development.IDE.Spans.Calculate
     - Development.IDE.Spans.Documentation
     - Development.IDE.Spans.Common
+    - Development.IDE.Spans.AtPoint
     - Development.IDE.Plugin.CodeAction
     - Development.IDE.Plugin.Completions
     - Development.IDE.Plugin.Completions.Logic

ghcide/bench/lib/Experiments.hs

@@ -324,9 +324,15 @@ data BenchRun = BenchRun
 badRun :: BenchRun
 badRun = BenchRun 0 0 0 0 0 False
 
+-- | Wait for all progress to be done
+-- Needs at least one progress done notification to return
 waitForProgressDone :: Session ()
-waitForProgressDone =
-      void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
+waitForProgressDone = loop
+  where
+    loop = do
+      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
+      done <- null <$> getIncompleteProgressSessions
+      unless done loop
 
 runBench ::
   (?config :: Config) =>

ghcide/exe/Arguments.hs

@@ -1,41 +1,52 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
-module Arguments(Arguments(..), getArguments) where
+module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where
 
 import Options.Applicative
+import HieDb.Run
 
+type Arguments = Arguments' IdeCmd
 
-data Arguments = Arguments
+data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP
+
+data Arguments' a = Arguments
     {argLSP :: Bool
     ,argsCwd :: Maybe FilePath
-    ,argFiles :: [FilePath]
     ,argsVersion :: Bool
     ,argsShakeProfiling :: Maybe FilePath
     ,argsOTMemoryProfiling :: Bool
     ,argsTesting :: Bool
     ,argsDisableKick :: Bool
     ,argsThreads :: Int
     ,argsVerbose :: Bool
+    ,argFilesOrCmd :: a
     }
 
 getArguments :: IO Arguments
 getArguments = execParser opts
   where
     opts = info (arguments <**> helper)
       ( fullDesc
-     <> progDesc "Used as a test bed to check your IDE will work"
      <> header "ghcide - the core of a Haskell IDE")
 
 arguments :: Parser Arguments
 arguments = Arguments
-      <$> switch (long "lsp" <> help "Start talking to an LSP server")
+      <$> switch (long "lsp" <> help "Start talking to an LSP client")
       <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
-      <*> many (argument str (metavar "FILES/DIRS..."))
       <*> switch (long "version" <> help "Show ghcide and GHC versions")
       <*> 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")
+      <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo)
+                   <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)
+                   <> command "lsp" (info (pure LSP <**> helper) lspInfo)  )
+         <|> Typecheck <$> fileCmd )
+  where
+    fileCmd = many (argument str (metavar "FILES/DIRS..."))
+    lspInfo = fullDesc <> progDesc "Start talking to an LSP client"
+    fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"
+    hieInfo = fullDesc <> progDesc "Query .hie files"

ghcide/exe/Main.hs

@@ -8,6 +8,7 @@ module Main(main) where
 import Arguments
 import Control.Concurrent.Extra
 import Control.Monad.Extra
+import Control.Exception.Safe
 import Control.Lens ( (^.) )
 import Data.Default
 import Data.List.Extra
@@ -29,7 +30,7 @@ import Development.IDE.Types.Options
 import Development.IDE.Types.Logger
 import Development.IDE.Plugin
 import Development.IDE.Plugin.Test as Test
-import Development.IDE.Session (loadSession)
+import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
 import Development.Shake (ShakeOptions (shakeThreads))
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
@@ -58,6 +59,8 @@ import Development.IDE.Plugin.HLS.GhcIde as GhcIde
 import Ide.Plugin.Config
 import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
 
+import HieDb.Run (Options(..), runCommand)
+
 ghcideVersion :: IO String
 ghcideVersion = do
   path <- getExecutablePath
@@ -78,13 +81,30 @@ main = do
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
+    whenJust argsCwd IO.setCurrentDirectory
+
+
+    dir <- IO.getCurrentDirectory
+    dbLoc <- getHieDbLoc dir
+
+    case argFilesOrCmd of
+      DbCmd opts cmd -> do
+        mlibdir <- setInitialDynFlags
+        case mlibdir of
+          Nothing -> exitWith $ ExitFailure 1
+          Just libdir ->
+            runCommand libdir opts{database = dbLoc} cmd
+      Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..}
+      _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..}
+
+
+runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO ()
+runIde Arguments{..} hiedb hiechan = do
     -- lock to avoid overlapping output on stdout
     lock <- newLock
     let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
             T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
 
-    whenJust argsCwd IO.setCurrentDirectory
-
     dir <- IO.getCurrentDirectory
 
     let hlsPlugins = pluginDescToIdePlugins $
@@ -107,14 +127,22 @@ main = do
         options = def { LSP.executeCommandCommands = Just hlsCommands
                       , LSP.completionTriggerCharacters = Just "."
                       }
-
-    if argLSP then do
+    case argFilesOrCmd of
+      Nothing -> do
         t <- offsetTime
         hPutStrLn stderr "Starting LSP server..."
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
         runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
+
+            -- We want to set the global DynFlags right now, so that we can use
+            -- `unsafeGlobalDynFlags` even before the project is configured
+            -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
+            -- before calling this function
+            _mlibdir <- setInitialDynFlags
+                          `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
+
             sessionLoader <- loadSession $ fromMaybe dir rootPath
             config <- fromMaybe def <$> getConfig
             let options = defOptions
@@ -138,8 +166,8 @@ main = do
                   unless argsDisableKick $
                     action kick
             initialise caps rules
-                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs
-    else do
+                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan
+      Just argFiles -> do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
         hSetEncoding stdout utf8
         hSetEncoding stderr utf8
@@ -174,7 +202,7 @@ main = do
                     }
             defOptions = defaultIdeOptions sessionLoader
             logLevel = if argsVerbose then minBound else Info
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files
@@ -203,7 +231,7 @@ main = do
 
         unless (null failed) (exitWith $ ExitFailure (length failed))
 
-{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-}
+{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-}
 
 expandFiles :: [FilePath] -> IO [FilePath]
 expandFiles = concatMapM $ \x -> do

ghcide/ghcide.cabal

@@ -47,7 +47,7 @@ library
         deepseq,
         directory,
         dlist,
-        extra,
+        extra >= 1.7.4,
         fuzzy,
         filepath,
         fingertree,
@@ -60,6 +60,7 @@ library
         hie-compat,
         hls-plugin-api >= 0.6,
         lens,
+        hiedb == 0.3.0.1,
         mtl,
         network-uri,
         parallel,
@@ -73,6 +74,7 @@ library
         safe-exceptions,
         shake >= 0.18.4,
         sorted-list,
+        sqlite-simple,
         stm,
         syb,
         text,
@@ -82,6 +84,9 @@ library
         utf8-string,
         vector,
         hslogger,
+        Diff,
+        vector,
+        bytestring-encoding,
         opentelemetry >=0.6.1,
         heapsize ==0.3.*
     if flag(ghc-lib)
@@ -251,6 +256,8 @@ executable ghcide
     if flag(ghc-lib)
       buildable: False
     default-language:   Haskell2010
+    include-dirs:
+        include
     hs-source-dirs:     exe
     ghc-options:
                 -threaded
@@ -264,13 +271,16 @@ executable ghcide
                 "-with-rtsopts=-I0 -A128M"
     main-is: Main.hs
     build-depends:
+        hiedb,
         aeson,
         base == 4.*,
         data-default,
         directory,
         extra,
         filepath,
         gitrev,
+        safe-exceptions,
+        ghc,
         hashable,
         haskell-lsp,
         haskell-lsp-types,
@@ -337,7 +347,7 @@ test-suite ghcide-tests
         hls-plugin-api,
         network-uri,
         lens,
-        lsp-test >= 0.11.0.6 && < 0.12,
+        lsp-test >= 0.12.0.0 && < 0.13,
         optparse-applicative,
         process,
         QuickCheck,
@@ -394,7 +404,7 @@ executable ghcide-bench
         extra,
         filepath,
         ghcide,
-        lsp-test >= 0.11.0.2 && < 0.12,
+        lsp-test >= 0.12.0.0 && < 0.13,
         optparse-applicative,
         process,
         safe-exceptions,