Move hiedb initialization stuff to session-loader

ghcide/exe/Main.hs

@@ -2,8 +2,6 @@
 -- 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 +29,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, cacheDir)
+import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
@@ -59,24 +57,8 @@ import Development.IDE.Plugin.HLS.GhcIde as GhcIde
 import Ide.Plugin.Config
 import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
 
-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.Concurrent.STM.TQueue
-import Control.Concurrent.STM (atomically)
-import Control.Exception
-import System.Directory
-import Data.ByteString.Base16
+import HieDb.Types (LibDir(..))
 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
@@ -89,30 +71,6 @@ 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 -> IndexQueue -> IO ()) -> IO ()
-runWithDb fp k =
-  withHieDb fp $ \writedb -> do
-    initConn writedb
-    chan <- newTQueueIO
-    race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
-  where
-    writerThread db chan = forever $ do
-      k <- atomically $ readTQueue 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
@@ -126,19 +84,10 @@ main = do
 
     -- We want to set the global DynFlags right now, so that we can use
     -- `unsafeGlobalDynFlags` even before the project is configured
+    libdir <- setInitialDynFlags
+
     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

ghcide/ghcide.cabal

@@ -72,6 +72,7 @@ library
         safe-exceptions,
         shake >= 0.18.4,
         sorted-list,
+        sqlite-simple,
         stm,
         syb,
         text,
@@ -290,8 +291,7 @@ executable ghcide
         lens,
         optparse-applicative,
         text,
-        unordered-containers,
-        sqlite-simple
+        unordered-containers
     other-modules:
         Arguments
         Paths_ghcide

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

@@ -1,4 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+#include "ghc-api-version.h"
 
 {-|
 The logic for setting up a ghcide session by tapping into hie-bios.
@@ -8,7 +10,9 @@ module Development.IDE.Session
   ,defaultLoadingOptions
   ,loadSession
   ,loadSessionWithOptions
-  ,cacheDir
+  ,setInitialDynFlags
+  ,getHieDbLoc
+  ,runWithDb
   ) where
 
 -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
@@ -72,6 +76,15 @@ import Packages
 import Control.Exception (evaluate)
 import Data.Void
 
+import HieDb.Create
+import HieDb.Types
+import HieDb.Utils
+import Database.SQLite.Simple
+import Control.Concurrent.STM.TQueue
+import Control.Concurrent.STM (atomically)
+import Maybes (MaybeT(runMaybeT))
+import HIE.Bios.Cradle (yamlConfig)
+
 
 data CacheDirs = CacheDirs
   { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
@@ -92,6 +105,47 @@ defaultLoadingOptions = SessionLoadingOptions
     ,getCacheDirs = getCacheDirsDefault
     }
 
+-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
+setInitialDynFlags :: IO (Maybe FilePath)
+setInitialDynFlags = do
+  dir <- IO.getCurrentDirectory
+  hieYaml <- runMaybeT $ yamlConfig dir
+  cradle <- maybe (HieBios.loadImplicitCradle $ addTrailingPathSeparator dir) HieBios.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
+  pure libdir
+
+-- | 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 -> IndexQueue -> IO ()) -> IO ()
+runWithDb fp k =
+  withHieDb fp $ \writedb -> do
+    initConn writedb
+    chan <- newTQueueIO
+    race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
+  where
+    writerThread db chan = forever $ do
+      k <- atomically $ readTQueue 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 $ B16.encode $ H.hash $ B.pack dir
+  cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
+  createDirectoryIfMissing True cDir
+  pure (cDir </> db)
+
 -- | Given a root directory, return a Shake 'Action' which setups an
 -- 'IdeGhcSession' given a file.
 -- Some of the many things this does:
@@ -716,8 +770,8 @@ notifyUserImplicitCradle fp =
     NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $
       "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
       <> T.pack fp <>
-      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\
-      \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
+      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <>
+      "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
 
 notifyCradleLoaded :: FilePath -> FromServerMessage
 notifyCradleLoaded fp =

ghcide/src/Development/IDE/Core/Shake.hs

@@ -64,6 +64,7 @@ module Development.IDE.Core.Shake(
     -- Exposed for testing.
     Q(..),
     IndexQueue,
+    HieDb,
     HieDbWriter(..),
     VFSHandle(..),
     addPersistentRule