Integrate hiedb

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 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")
       <*> 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 <$> 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 server"
+    fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work"
+    hieInfo = fullDesc <> progDesc "Query .hie files"

exe/Main.hs

@@ -2,6 +2,8 @@
 -- SPDX-License-Identifier: Apache-2.0
 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+#include "ghc-api-version.h"
 
 module Main(main) where
 
@@ -31,7 +33,7 @@ import Development.IDE.Plugin
 import Development.IDE.Plugin.Completions as Completions
 import Development.IDE.Plugin.CodeAction as CodeAction
 import Development.IDE.Plugin.Test as Test
-import Development.IDE.Session (loadSession)
+import Development.IDE.Session (loadSession, cacheDir)
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
@@ -55,6 +57,23 @@ import Text.Printf
 import Development.IDE.Core.Tracing
 import Development.IDE.Types.Shake (Key(Key))
 
+import HieDb.Create
+import HieDb.Types
+import HieDb.Utils
+import Database.SQLite.Simple
+import qualified Data.ByteString.Char8 as B
+import qualified Crypto.Hash.SHA1 as H
+import Control.Concurrent.Async
+import Control.Exception
+import System.Directory
+import Data.ByteString.Base16
+import HieDb.Run (Options(..), runCommand)
+import Maybes (MaybeT(runMaybeT))
+import HIE.Bios.Types (CradleLoadResult(..))
+import HIE.Bios.Environment (getRuntimeGhcLibDir)
+import DynFlags
+
+
 ghcideVersion :: IO String
 ghcideVersion = do
   path <- getExecutablePath
@@ -66,6 +85,31 @@ ghcideVersion = do
              <> ") (PATH: " <> path <> ")"
              <> gitHashSection
 
+-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
+-- 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 -> HieWriterChan -> IO ()) -> IO ()
+runWithDb fp k =
+  withHieDb fp $ \writedb -> do
+    execute_ (getConn writedb) "PRAGMA journal_mode=WAL;"
+    initConn writedb
+    chan <- newChan
+    race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
+  where
+    writerThread db chan = forever $ do
+      k <- readChan chan
+      k db `catch` \e@SQLError{} -> do
+        hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e
+
+getHieDbLoc :: FilePath -> IO FilePath
+getHieDbLoc dir = do
+  let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
+      dirHash = B.unpack $ encode $ H.hash $ B.pack dir
+  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
+  createDirectoryIfMissing True cDir
+  pure (cDir </> db)
+
 main :: IO ()
 main = do
     -- WARNING: If you write to stdout before runLanguageServer
@@ -75,15 +119,47 @@ main = do
     if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
     else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
 
+    whenJust argsCwd IO.setCurrentDirectory
+
+    -- We want to set the global DynFlags right now, so that we can use
+    -- `unsafeGlobalDynFlags` even before the project is configured
+    dir <- IO.getCurrentDirectory
+    dbLoc <- getHieDbLoc dir
+    hieYaml <- runMaybeT $ yamlConfig dir
+    cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
+    libDirRes <- getRuntimeGhcLibDir cradle
+    libdir <- case libDirRes of
+        CradleSuccess libdir -> pure $ Just libdir
+        CradleFail err -> do
+          hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show err
+          return Nothing
+        CradleNone -> return Nothing
+    dynFlags <- mapM (dynFlagsForPrinting . LibDir) libdir
+    mapM_ setUnsafeGlobalDynFlags dynFlags
+
+    case argFilesOrCmd of
+      DbCmd cmd -> do
+        let opts :: Options
+            opts = Options
+              { database = dbLoc
+              , trace = False
+              , quiet = False
+              , virtualFile = False
+              }
+        runCommand (LibDir $ fromJust libdir) opts cmd
+      Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde dir Arguments{..}
+      _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde dir Arguments{..}
+
+
+runIde :: FilePath -> Arguments' (Maybe [FilePath]) -> HieDb -> HieWriterChan -> IO ()
+runIde dir Arguments{..} hiedb hiechan = do
+    command <- makeLspCommandId "typesignature.add"
+
     -- 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
-    command <- makeLspCommandId "typesignature.add"
 
     let plugins = Completions.plugin <> CodeAction.plugin
             <> if argsTesting then Test.plugin else mempty
@@ -97,8 +173,8 @@ main = do
         options = def { LSP.executeCommandCommands = Just [command]
                       , 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!"
@@ -127,8 +203,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
@@ -162,7 +238,7 @@ main = do
                     , optCheckProject      = CheckProject False
                     }
             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

ghcide.cabal

@@ -56,6 +56,7 @@ library
         haskell-lsp-types == 0.22.*,
         haskell-lsp == 0.22.*,
         hie-compat,
+        hiedb,
         mtl,
         network-uri,
         parallel,
@@ -239,6 +240,8 @@ executable ghcide
     if flag(ghc-lib)
       buildable: False
     default-language:   Haskell2010
+    include-dirs:
+        include
     hs-source-dirs:     exe
     ghc-options:
                 -threaded
@@ -253,13 +256,21 @@ executable ghcide
                 "-with-rtsopts=-I0 -qg -A128M"
     main-is: Main.hs
     build-depends:
+        time,
+        async,
+        bytestring,
+        base16-bytestring,
+        cryptohash-sha1,
+        hslogger,
+        hiedb,
         aeson,
         base == 4.*,
         data-default,
         directory,
         extra,
         filepath,
         gitrev,
+        ghc,
         hashable,
         haskell-lsp,
         haskell-lsp-types,
@@ -269,7 +280,8 @@ executable ghcide
         lens,
         optparse-applicative,
         text,
-        unordered-containers
+        unordered-containers,
+        sqlite-simple
     other-modules:
         Arguments
         Paths_ghcide

session-loader/Development/IDE/Session.hs

@@ -8,6 +8,7 @@ module Development.IDE.Session
   ,defaultLoadingOptions
   ,loadSession
   ,loadSessionWithOptions
+  ,cacheDir
   ) where
 
 -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses

src/Development/IDE/Core/Compile.hs

@@ -21,7 +21,8 @@ module Development.IDE.Core.Compile
   , generateObjectCode
   , generateByteCode
   , generateHieAsts
-  , writeHieFile
+  , writeAndIndexHieFile
+  , indexHieFile
   , writeHiFile
   , getModSummaryFromImports
   , loadHieFile
@@ -37,11 +38,16 @@ import Development.IDE.Core.Preprocessor
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Error
 import Development.IDE.GHC.Warnings
+import Development.IDE.Spans.Common
 import Development.IDE.Types.Diagnostics
 import Development.IDE.GHC.Orphans()
 import Development.IDE.GHC.Util
 import Development.IDE.Types.Options
 import Development.IDE.Types.Location
+import Outputable
+import Control.Concurrent.Chan
+
+import HieDb
 
 import Language.Haskell.LSP.Types (DiagnosticTag(..))
 
@@ -95,6 +101,9 @@ import PrelNames
 import HeaderInfo
 import Maybes (orElse)
 
+import Control.Concurrent.Extra (modifyVar_,modifyVar)
+import qualified Data.HashSet as HashSet
+
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
     :: IdeOptions
@@ -390,20 +399,37 @@ generateHieAsts hscEnv tcm =
   where
     dflags = hsc_dflags hscEnv
 
-writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
-writeHieFile hscEnv mod_summary exports ast source =
+indexHieFile :: HieDbWriter -> ModSummary -> NormalizedFilePath -> Compat.HieFile -> IO ()
+indexHieFile dbwriter mod_summary srcPath hf = do
+  index <- modifyVar (pendingIndexes dbwriter) $ \pending -> pure $
+    if HashSet.member srcPath pending
+      then (pending,False)
+      else (HashSet.insert srcPath pending, True)
+  when index $ writeChan (channel dbwriter) $ \db -> do
+    hPutStrLn stderr $ "Started indexing .hie file: " ++ targetPath ++ " for: " ++ show srcPath
+    addRefsFromLoaded db targetPath (Just $ fromNormalizedFilePath srcPath) True modtime hf
+    modifyVar_ (pendingIndexes dbwriter) (pure . HashSet.delete srcPath)
+    hPutStrLn stderr $ "Finished indexing .hie file: " ++ targetPath
+  where
+    modtime      = ms_hs_date mod_summary
+    mod_location = ms_location mod_summary
+    targetPath   = Compat.ml_hie_file mod_location
+
+writeAndIndexHieFile :: HscEnv -> HieDbWriter -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
+writeAndIndexHieFile hscEnv hiechan mod_summary srcPath exports ast source =
   handleGenerationErrors dflags "extended interface write/compression" $ do
     hf <- runHsc hscEnv $
       GHC.mkHieFile' mod_summary exports ast source
     atomicFileWrite targetPath $ flip GHC.writeHieFile hf
+    indexHieFile hiechan mod_summary srcPath hf
   where
     dflags       = hsc_dflags hscEnv
     mod_location = ms_location mod_summary
     targetPath   = Compat.ml_hie_file mod_location
 
 writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic]
 writeHiFile hscEnv tc =
-  handleGenerationErrors dflags "interface generation" $ do
+  handleGenerationErrors dflags "interface write" $ do
     atomicFileWrite targetPath $ \fp ->
       writeIfaceFile dflags fp modIface
   where
@@ -736,7 +762,7 @@ getDocsBatch hsc_env _mod _names = do
                else pure (Right ( Map.lookup name dmap
                                 , Map.findWithDefault Map.empty name amap))
     case res of
-        Just x -> return $ map (first prettyPrint) x
+        Just x -> return $ map (first $ T.unpack . showGhc) x
         Nothing -> throwErrors errs
   where
     throwErrors = liftIO . throwIO . mkSrcErr

src/Development/IDE/Core/FileExists.hs

@@ -6,6 +6,7 @@ module Development.IDE.Core.FileExists
   , modifyFileExists
   , getFileExists
   , watchedGlobs
+  , GetFileExists(..)
   )
 where
 

src/Development/IDE/Core/OfInterest.hs

@@ -25,7 +25,7 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Text as T
 import Data.Tuple.Extra
 import Development.Shake
-import Control.Monad (void)
+import Control.Monad
 
 import Development.IDE.Types.Exports
 import Development.IDE.Types.Location