Skip to content

Commit 39f460a

Browse files
wz1000wz1000
committed
Move hiedb initialization stuff to session-loader
1 parent c981151 commit 39f460a

File tree

4 files changed

+64
-67
lines changed

4 files changed

+64
-67
lines changed

‎ghcide/exe/Main.hs

+4-55
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,6 @@
22
-- SPDX-License-Identifier: Apache-2.0
33
{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
44
{-# LANGUAGE TemplateHaskell #-}
5-
{-# LANGUAGE CPP #-}
6-
#include "ghc-api-version.h"
75

86
module Main(main) where
97

@@ -31,7 +29,7 @@ import Development.IDE.Types.Options
3129
import Development.IDE.Types.Logger
3230
import Development.IDE.Plugin
3331
import Development.IDE.Plugin.Test as Test
34-
import Development.IDE.Session (loadSession, cacheDir)
32+
import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
3533
import qualified Language.Haskell.LSP.Core as LSP
3634
import Language.Haskell.LSP.Messages
3735
import Language.Haskell.LSP.Types
@@ -59,24 +57,8 @@ import Development.IDE.Plugin.HLS.GhcIde as GhcIde
5957
import Ide.Plugin.Config
6058
import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)
6159

62-
import HieDb.Create
63-
import HieDb.Types
64-
import HieDb.Utils
65-
import Database.SQLite.Simple
66-
import qualified Data.ByteString.Char8 as B
67-
import qualified Crypto.Hash.SHA1 as H
68-
import Control.Concurrent.Async
69-
import Control.Concurrent.STM.TQueue
70-
import Control.Concurrent.STM (atomically)
71-
import Control.Exception
72-
import System.Directory
73-
import Data.ByteString.Base16
60+
import HieDb.Types (LibDir(..))
7461
import HieDb.Run (Options(..), runCommand)
75-
import Maybes (MaybeT(runMaybeT))
76-
import HIE.Bios.Types (CradleLoadResult(..))
77-
import HIE.Bios.Environment (getRuntimeGhcLibDir)
78-
import DynFlags
79-
8062

8163
ghcideVersion :: IO String
8264
ghcideVersion = do
@@ -89,30 +71,6 @@ ghcideVersion = do
8971
<> ") (PATH: " <> path <> ")"
9072
<> gitHashSection
9173

92-
-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
93-
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
94-
-- by a worker thread using a dedicated database connection.
95-
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
96-
runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
97-
runWithDb fp k =
98-
withHieDb fp $ \writedb -> do
99-
initConn writedb
100-
chan <- newTQueueIO
101-
race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
102-
where
103-
writerThread db chan = forever $ do
104-
k <- atomically $ readTQueue chan
105-
k db `catch` \e@SQLError{} -> do
106-
hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e
107-
108-
getHieDbLoc :: FilePath -> IO FilePath
109-
getHieDbLoc dir = do
110-
let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
111-
dirHash = B.unpack $ encode $ H.hash $ B.pack dir
112-
cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
113-
createDirectoryIfMissing True cDir
114-
pure (cDir </> db)
115-
11674
main :: IO ()
11775
main = do
11876
-- WARNING: If you write to stdout before runLanguageServer
@@ -126,19 +84,10 @@ main = do
12684

12785
-- We want to set the global DynFlags right now, so that we can use
12886
-- `unsafeGlobalDynFlags` even before the project is configured
87+
libdir <- setInitialDynFlags
88+
12989
dir <- IO.getCurrentDirectory
13090
dbLoc <- getHieDbLoc dir
131-
hieYaml <- runMaybeT $ yamlConfig dir
132-
cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
133-
libDirRes <- getRuntimeGhcLibDir cradle
134-
libdir <- case libDirRes of
135-
CradleSuccess libdir -> pure $ Just libdir
136-
CradleFail err -> do
137-
hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show err
138-
return Nothing
139-
CradleNone -> return Nothing
140-
dynFlags <- mapM (dynFlagsForPrinting . LibDir) libdir
141-
mapM_ setUnsafeGlobalDynFlags dynFlags
14291

14392
case argFilesOrCmd of
14493
DbCmd cmd -> do

‎ghcide/ghcide.cabal

+2-9
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,7 @@ library
7272
safe-exceptions,
7373
shake >= 0.18.4,
7474
sorted-list,
75+
sqlite-simple,
7576
stm,
7677
syb,
7778
text,
@@ -264,13 +265,6 @@ executable ghcide
264265
"-with-rtsopts=-I0 -qg -A128M"
265266
main-is: Main.hs
266267
build-depends:
267-
time,
268-
stm,
269-
async,
270-
bytestring,
271-
base16-bytestring,
272-
cryptohash-sha1,
273-
hslogger,
274268
hiedb,
275269
aeson,
276270
base == 4.*,
@@ -290,8 +284,7 @@ executable ghcide
290284
lens,
291285
optparse-applicative,
292286
text,
293-
unordered-containers,
294-
sqlite-simple
287+
unordered-containers
295288
other-modules:
296289
Arguments
297290
Paths_ghcide

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

+57-3
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
11
{-# LANGUAGE TypeFamilies #-}
2+
{-# LANGUAGE CPP #-}
3+
#include "ghc-api-version.h"
24

35
{-|
46
The logic for setting up a ghcide session by tapping into hie-bios.
@@ -8,7 +10,9 @@ module Development.IDE.Session
810
,defaultLoadingOptions
911
,loadSession
1012
,loadSessionWithOptions
11-
,cacheDir
13+
,setInitialDynFlags
14+
,getHieDbLoc
15+
,runWithDb
1216
) where
1317

1418
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
@@ -72,6 +76,15 @@ import Packages
7276
import Control.Exception (evaluate)
7377
import Data.Void
7478

79+
import HieDb.Create
80+
import HieDb.Types
81+
import HieDb.Utils
82+
import Database.SQLite.Simple
83+
import Control.Concurrent.STM.TQueue
84+
import Control.Concurrent.STM (atomically)
85+
import Maybes (MaybeT(runMaybeT))
86+
import HIE.Bios.Cradle (yamlConfig)
87+
7588

7689
data CacheDirs = CacheDirs
7790
{ hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath}
@@ -92,6 +105,47 @@ defaultLoadingOptions = SessionLoadingOptions
92105
,getCacheDirs = getCacheDirsDefault
93106
}
94107

108+
-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
109+
setInitialDynFlags :: IO (Maybe FilePath)
110+
setInitialDynFlags = do
111+
dir <- IO.getCurrentDirectory
112+
hieYaml <- runMaybeT $ yamlConfig dir
113+
cradle <- maybe (HieBios.loadImplicitCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml
114+
libDirRes <- getRuntimeGhcLibDir cradle
115+
libdir <- case libDirRes of
116+
CradleSuccess libdir -> pure $ Just libdir
117+
CradleFail err -> do
118+
hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show err
119+
return Nothing
120+
CradleNone -> return Nothing
121+
dynFlags <- mapM (dynFlagsForPrinting . LibDir) libdir
122+
mapM_ setUnsafeGlobalDynFlags dynFlags
123+
pure libdir
124+
125+
-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
126+
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
127+
-- by a worker thread using a dedicated database connection.
128+
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
129+
runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
130+
runWithDb fp k =
131+
withHieDb fp $ \writedb -> do
132+
initConn writedb
133+
chan <- newTQueueIO
134+
race_ (writerThread writedb chan) (withHieDb fp (flip k chan))
135+
where
136+
writerThread db chan = forever $ do
137+
k <- atomically $ readTQueue chan
138+
k db `catch` \e@SQLError{} -> do
139+
hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e
140+
141+
getHieDbLoc :: FilePath -> IO FilePath
142+
getHieDbLoc dir = do
143+
let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb"
144+
dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir
145+
cDir <- IO.getXdgDirectory IO.XdgCache cacheDir
146+
createDirectoryIfMissing True cDir
147+
pure (cDir </> db)
148+
95149
-- | Given a root directory, return a Shake 'Action' which setups an
96150
-- 'IdeGhcSession' given a file.
97151
-- Some of the many things this does:
@@ -716,8 +770,8 @@ notifyUserImplicitCradle fp =
716770
NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $
717771
"No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
718772
<> T.pack fp <>
719-
".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\
720-
\You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
773+
".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <>
774+
"You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
721775

722776
notifyCradleLoaded :: FilePath -> FromServerMessage
723777
notifyCradleLoaded fp =

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

+1
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ module Development.IDE.Core.Shake(
6464
-- Exposed for testing.
6565
Q(..),
6666
IndexQueue,
67+
HieDb,
6768
HieDbWriter(..),
6869
VFSHandle(..),
6970
addPersistentRule

0 commit comments

Comments
 (0)