Skip to content

Commit 2fab83a

Browse files
nlandernlander
committed
Factor out common hie file load checks
1 parent 515f90c commit 2fab83a

File tree

4 files changed

+107
-56
lines changed

4 files changed

+107
-56
lines changed

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ import qualified Data.Text as T
4848
import Data.Time.Clock
4949
import Data.Version
5050
import Development.IDE.Core.RuleTypes
51+
import qualified Development.IDE.Core.Rules as Rules
5152
import Development.IDE.Core.Shake hiding (Log, Priority,
5253
withHieDb)
5354
import qualified Development.IDE.GHC.Compat as Compat
@@ -127,6 +128,7 @@ data Log
127128
| LogNoneCradleFound FilePath
128129
| LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
129130
| LogHieBios HieBios.Log
131+
| LogRules Rules.Log
130132
deriving instance Show Log
131133

132134
instance Pretty Log where
@@ -197,6 +199,7 @@ instance Pretty Log where
197199
LogNewComponentCache componentCache ->
198200
"New component cache HscEnvEq:" <+> viaShow componentCache
199201
LogHieBios log -> pretty log
202+
LogRules log -> pretty log
200203

201204
-- | Bump this version number when making changes to the format of the data stored in hiedb
202205
hiedbDataVersion :: String
@@ -824,7 +827,7 @@ newComponentCache recorder extras exts cradlePath cfp hsc_env uids ci = do
824827
#endif
825828

826829
let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
827-
henv <- newFunc extras hscEnv' uids
830+
henv <- newFunc (cmapWithPrio LogRules recorder) extras hscEnv' uids
828831
let targetEnv = ([], Just henv)
829832
targetDepends = componentDependencyInfo ci
830833
res = (targetEnv, targetDepends)

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

Lines changed: 65 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,9 @@ module Development.IDE.Core.Rules(
1313
-- * Types
1414
IdeState, GetParsedModule(..), TransitiveDependencies(..),
1515
Priority(..), GhcSessionIO(..), GetClientSettings(..),
16+
HieFileCheck(..),
1617
-- * Functions
18+
checkHieFile,
1719
priorityTypeCheck,
1820
priorityGenerateCore,
1921
priorityFilesOfInterest,
@@ -78,6 +80,7 @@ import Data.Aeson (Result (Success),
7880
toJSON)
7981
import qualified Data.Aeson.Types as A
8082
import qualified Data.Binary as B
83+
import Data.Bool (bool)
8184
import qualified Data.ByteString as BS
8285
import qualified Data.ByteString.Lazy as LBS
8386
import Data.Coerce
@@ -129,7 +132,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint
129132
import Development.IDE.Spans.Documentation
130133
import Development.IDE.Spans.LocalBindings
131134
import Development.IDE.Types.Diagnostics as Diag
132-
import Development.IDE.Types.HscEnvEq
135+
import {-# SOURCE #-} Development.IDE.Types.HscEnvEq
133136
import Development.IDE.Types.Location
134137
import Development.IDE.Types.Options
135138
import qualified GHC.LanguageExtensions as LangExt
@@ -172,8 +175,9 @@ data Log
172175
= LogShake Shake.Log
173176
| LogReindexingHieFile !NormalizedFilePath
174177
| LogLoadingHieFile !NormalizedFilePath
175-
| LogLoadingHieFileFail !FilePath !SomeException
176-
| LogLoadingHieFileSuccess !FilePath
178+
| LogMissingHieFile !NormalizedFilePath
179+
| LogLoadingHieFileFail !NormalizedFilePath !SomeException
180+
| LogLoadingHieFileSuccess !NormalizedFilePath
177181
| LogTypecheckedFOI !NormalizedFilePath
178182
deriving Show
179183

@@ -184,13 +188,15 @@ instance Pretty Log where
184188
"Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path)
185189
LogLoadingHieFile path ->
186190
"LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path)
191+
LogMissingHieFile path ->
192+
"MISSING HIE FILE" <+> pretty (fromNormalizedFilePath path)
187193
LogLoadingHieFileFail path e ->
188194
nest 2 $
189195
vcat
190-
[ "FAILED LOADING HIE FILE FOR" <+> pretty path
196+
[ "FAILED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path)
191197
, pretty (displayException e) ]
192198
LogLoadingHieFileSuccess path ->
193-
"SUCCEEDED LOADING HIE FILE FOR" <+> pretty path
199+
"SUCCEEDED LOADING HIE FILE" <+> pretty (fromNormalizedFilePath path)
194200
LogTypecheckedFOI path -> vcat
195201
[ "Typechecked a file which is not currently open in the editor:" <+> pretty (fromNormalizedFilePath path)
196202
, "This can indicate a bug which results in excessive memory usage."
@@ -665,14 +671,14 @@ readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -
665671
readHieFileForSrcFromDisk recorder file = do
666672
ShakeExtras{withHieDb} <- ask
667673
row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file)
668-
let hie_loc = HieDb.hieModuleHieFile row
674+
let hie_loc = toNormalizedFilePath' $ HieDb.hieModuleHieFile row
669675
liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFile file
670676
exceptToMaybeT $ readHieFileFromDisk recorder hie_loc
671677

672-
readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile
678+
readHieFileFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> ExceptT SomeException IdeAction Compat.HieFile
673679
readHieFileFromDisk recorder hie_loc = do
674680
nc <- asks ideNc
675-
res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc
681+
res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) (fromNormalizedFilePath hie_loc)
676682
let log = (liftIO .) . logWith recorder
677683
case res of
678684
Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e
@@ -854,6 +860,43 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake reco
854860
let !fp = Just $! hiFileFingerPrint x
855861
return (fp, (diags, Just x))
856862

863+
data HieFileCheck
864+
= HieFileMissing
865+
| HieAlreadyIndexed
866+
| CouldNotLoadHie SomeException
867+
| DoIndexing Util.Fingerprint HieFile
868+
869+
checkHieFile
870+
:: Recorder (WithPriority Log)
871+
-> ShakeExtras
872+
-> String
873+
-> NormalizedFilePath
874+
-> IO HieFileCheck
875+
checkHieFile recorder se@ShakeExtras{withHieDb} tag hieFileLocation = do
876+
hieFileExists <- doesFileExist $ fromNormalizedFilePath hieFileLocation
877+
bool logHieFileMissing checkExistingHieFile hieFileExists
878+
where
879+
logHieFileMissing :: IO HieFileCheck
880+
logHieFileMissing = do
881+
let log :: Log
882+
log = LogMissingHieFile hieFileLocation
883+
logWith recorder Logger.Debug log
884+
pure HieFileMissing
885+
checkExistingHieFile :: IO HieFileCheck
886+
checkExistingHieFile = do
887+
hash <- Util.getFileHash $ fromNormalizedFilePath hieFileLocation
888+
mrow <- withHieDb (\hieDb -> HieDb.lookupHieFileFromHash hieDb hash)
889+
dbHieFileLocation <- traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
890+
bool (tryLoadingHieFile hash) (pure HieAlreadyIndexed) $
891+
Just hieFileLocation == fmap toNormalizedFilePath' dbHieFileLocation
892+
tryLoadingHieFile :: Util.Fingerprint -> IO HieFileCheck
893+
tryLoadingHieFile hash = do
894+
ehf <- runIdeAction tag se $ runExceptT $
895+
readHieFileFromDisk recorder hieFileLocation
896+
pure $ case ehf of
897+
Left err -> CouldNotLoadHie err
898+
Right hf -> DoIndexing hash hf
899+
857900
-- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file?
858901
-- This function is responsible for ensuring database consistency
859902
-- Whenever we read a `.hi` file, we must check to ensure we have also
@@ -871,31 +914,20 @@ getModIfaceFromDiskAndIndexRule recorder =
871914

872915
-- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db
873916
let ms = hirModSummary x
874-
hie_loc = Compat.ml_hie_file $ ms_location ms
875-
hash <- liftIO $ Util.getFileHash hie_loc
876-
mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))
877-
hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
878-
case mrow of
879-
Just row
880-
| hash == HieDb.modInfoHash (HieDb.hieModInfo row)
881-
&& Just hie_loc == hie_loc'
882-
-> do
883-
-- All good, the db has indexed the file
884-
when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $
885-
LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
886-
toJSON $ fromNormalizedFilePath f
887-
-- Not in db, must re-index
888-
_ -> do
889-
ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $
890-
readHieFileFromDisk recorder hie_loc
891-
case ehf of
892-
-- Uh oh, we failed to read the file for some reason, need to regenerate it
893-
Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err
894-
-- can just re-index the file we read from disk
895-
Right hf -> liftIO $ do
896-
logWith recorder Logger.Debug $ LogReindexingHieFile f
897-
indexHieFile se (toNormalizedFilePath' hie_loc) (HieDb.RealFile $ fromNormalizedFilePath f) hash hf
898-
917+
hie_loc = toNormalizedFilePath' $ Compat.ml_hie_file $ ms_location ms
918+
hieFailure :: Maybe SomeException -> Action ()
919+
hieFailure mErr = fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++
920+
maybe "Does not exist" displayException mErr
921+
hieCheck <- liftIO $ checkHieFile recorder se "GetModIfaceFromDiskAndIndex" hie_loc
922+
case hieCheck of
923+
HieFileMissing -> hieFailure Nothing
924+
HieAlreadyIndexed -> when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $
925+
LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
926+
toJSON $ fromNormalizedFilePath f
927+
CouldNotLoadHie err -> hieFailure $ Just err
928+
DoIndexing hash hf -> liftIO $ do
929+
logWith recorder Logger.Debug $ LogReindexingHieFile f
930+
indexHieFile se hie_loc (HieDb.RealFile $ fromNormalizedFilePath f) hash hf
899931
return (Just x)
900932

901933
newtype DisplayTHWarning = DisplayTHWarning (IO())

‎ghcide/src/Development/IDE/Types/HscEnvEq.hs

Lines changed: 21 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -19,27 +19,26 @@ import Control.Concurrent.STM.TQueue (unGetTQueue)
1919
import Control.Concurrent.Strict (modifyVar, newVar)
2020
import Control.DeepSeq (force)
2121
import Control.Exception (evaluate, mask, throwIO)
22-
import Control.Exception.Safe (tryAny)
2322
import Control.Monad (unless)
2423
import Control.Monad.Extra (eitherM, join, mapMaybeM, void)
2524
import Data.Either (fromRight)
2625
import Data.Foldable (traverse_)
2726
import qualified Data.Map as Map
2827
import Data.Set (Set)
2928
import qualified Data.Set as Set
30-
import qualified Data.Text as T
3129
import Data.Unique (Unique)
3230
import qualified Data.Unique as Unique
33-
import Development.IDE.Core.Compile (indexHieFile, loadHieFile)
34-
import Development.IDE.Core.Shake (HieDbWriter(indexQueue), ShakeExtras(hiedbWriter, ideNc, logger, lspEnv), mkUpdater)
31+
import Development.IDE.Core.Compile (indexHieFile)
32+
import Development.IDE.Core.Rules (HieFileCheck(..), Log, checkHieFile)
33+
import Development.IDE.Core.Shake (HieDbWriter(indexQueue), ShakeExtras(hiedbWriter, lspEnv))
3534
import Development.IDE.GHC.Compat
3635
import qualified Development.IDE.GHC.Compat.Util as Maybes
3736
import Development.IDE.GHC.Error (catchSrcErrors)
3837
import Development.IDE.GHC.Util (lookupPackageConfig)
3938
import Development.IDE.Graph.Classes
4039
import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
41-
import Development.IDE.Types.Location (toNormalizedFilePath')
42-
import qualified Development.IDE.Types.Logger as Logger
40+
import Development.IDE.Types.Location (NormalizedFilePath, toNormalizedFilePath')
41+
import Development.IDE.Types.Logger (Recorder, WithPriority)
4342
import HieDb (SourceFile(FakeFile), removeDependencySrcFiles)
4443
import Language.LSP.Server (resRootPath)
4544
import OpenTelemetry.Eventlog (withSpan)
@@ -73,19 +72,19 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do
7372
update <$> Unique.newUnique
7473

7574
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
76-
newHscEnvEq :: FilePath -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
77-
newHscEnvEq cradlePath se hscEnv0 deps = do
75+
newHscEnvEq :: FilePath -> Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
76+
newHscEnvEq cradlePath recorder se hscEnv0 deps = do
7877
let relativeToCradle = (takeDirectory cradlePath </>)
7978
hscEnv = removeImportPaths hscEnv0
8079

8180
-- Make Absolute since targets are also absolute
8281
importPathsCanon <-
8382
mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
8483

85-
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) se hscEnv deps
84+
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) recorder se hscEnv deps
8685

87-
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
88-
newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
86+
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
87+
newHscEnvEqWithImportPaths envImportPaths recorder se hscEnv deps = do
8988

9089
indexDependencyHieFiles
9190

@@ -150,15 +149,16 @@ newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
150149
traverse_ (indexModuleHieFile hieDir) modIfaces
151150
indexModuleHieFile :: FilePath -> ModIface -> IO ()
152151
indexModuleHieFile hieDir modIface = do
153-
let hiePath :: FilePath
154-
hiePath = hieDir </> toFilePath (moduleName $ mi_module modIface) ++ ".hie"
155-
hieResults <- tryAny $ loadHieFile (mkUpdater $ ideNc se) hiePath
156-
case hieResults of
157-
Left e -> Logger.logDebug (logger se) $
158-
"Failed to index dependency HIE file:\n"
159-
<> T.pack (show e)
160-
Right hie ->
161-
indexHieFile se (toNormalizedFilePath' hiePath) (FakeFile Nothing) (mi_src_hash modIface) hie
152+
let hiePath :: NormalizedFilePath
153+
hiePath = toNormalizedFilePath' $
154+
hieDir </> toFilePath (moduleName $ mi_module modIface) ++ ".hie"
155+
hieCheck <- checkHieFile recorder se "newHscEnvEqWithImportPaths" hiePath
156+
case hieCheck of
157+
HieFileMissing -> return ()
158+
HieAlreadyIndexed -> return ()
159+
CouldNotLoadHie _e -> return ()
160+
DoIndexing hash hie ->
161+
indexHieFile se hiePath (FakeFile Nothing) hash hie
162162
toFilePath :: ModuleName -> FilePath
163163
toFilePath = separateDirectories . prettyModuleName
164164
where
@@ -214,7 +214,7 @@ instance Ord Package where
214214

215215
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
216216
newHscEnvEqPreserveImportPaths
217-
:: ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
217+
:: Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
218218
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
219219

220220
-- | Unwrap the 'HscEnv' with the original import paths.

‎ghcide/src/Development/IDE/Types/HscEnvEq.hs-boot

Lines changed: 17 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,16 @@
1-
module Development.IDE.Types.HscEnvEq (HscEnvEq) where
1+
module Development.IDE.Types.HscEnvEq
2+
( HscEnvEq,
3+
hscEnv,
4+
hscEnvWithImportPaths,
5+
updateHscEnvEq,
6+
envImportPaths,
7+
deps
8+
) where
29

310
import Data.Set (Set)
411
import Data.Unique (Unique)
512
import Development.IDE.GHC.Compat
13+
import Development.IDE.Graph.Classes
614
import Development.IDE.Types.Exports (ExportsMap)
715

816
-- | An 'HscEnv' with equality. Two values are considered equal
@@ -24,3 +32,11 @@ data HscEnvEq = HscEnvEq
2432
-- So it's wrapped in IO here for error handling
2533
-- If Nothing, 'listVisibleModuleNames' panic
2634
}
35+
36+
instance Show HscEnvEq
37+
instance Hashable HscEnvEq
38+
instance NFData HscEnvEq
39+
40+
updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq
41+
42+
hscEnvWithImportPaths :: HscEnvEq -> HscEnv

0 commit comments

Comments
 (0)