Skip to content

Commit 59b518b

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

File tree

4 files changed

+106
-51
lines changed

4 files changed

+106
-51
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: 20 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -31,14 +31,17 @@ import qualified Data.Text as T
3131
import Data.Unique (Unique)
3232
import qualified Data.Unique as Unique
3333
import Development.IDE.Core.Compile (indexHieFile, loadHieFile)
34+
import Development.IDE.Core.Rules (HieFileCheck(..), Log, checkHieFile)
3435
import Development.IDE.Core.Shake (HieDbWriter(indexQueue), ShakeExtras(hiedbWriter, ideNc, logger, lspEnv), mkUpdater)
3536
import Development.IDE.GHC.Compat
3637
import qualified Development.IDE.GHC.Compat.Util as Maybes
3738
import Development.IDE.GHC.Error (catchSrcErrors)
3839
import Development.IDE.GHC.Util (lookupPackageConfig)
40+
import qualified Development.IDE.GHC.Compat.Util as Util
3941
import Development.IDE.Graph.Classes
4042
import Development.IDE.Types.Exports (ExportsMap, createExportsMap)
41-
import Development.IDE.Types.Location (toNormalizedFilePath')
43+
import Development.IDE.Types.Location (NormalizedFilePath, toNormalizedFilePath')
44+
import Development.IDE.Types.Logger (Recorder, WithPriority)
4245
import qualified Development.IDE.Types.Logger as Logger
4346
import HieDb (SourceFile(FakeFile), removeDependencySrcFiles)
4447
import Language.LSP.Server (resRootPath)
@@ -73,19 +76,19 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do
7376
update <$> Unique.newUnique
7477

7578
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
76-
newHscEnvEq :: FilePath -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
77-
newHscEnvEq cradlePath se hscEnv0 deps = do
79+
newHscEnvEq :: FilePath -> Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
80+
newHscEnvEq cradlePath recorder se hscEnv0 deps = do
7881
let relativeToCradle = (takeDirectory cradlePath </>)
7982
hscEnv = removeImportPaths hscEnv0
8083

8184
-- Make Absolute since targets are also absolute
8285
importPathsCanon <-
8386
mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
8487

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

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

9093
indexDependencyHieFiles
9194

@@ -150,15 +153,16 @@ newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
150153
traverse_ (indexModuleHieFile hieDir) modIfaces
151154
indexModuleHieFile :: FilePath -> ModIface -> IO ()
152155
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
156+
let hiePath :: NormalizedFilePath
157+
hiePath = toNormalizedFilePath' $
158+
hieDir </> toFilePath (moduleName $ mi_module modIface) ++ ".hie"
159+
hieCheck <- checkHieFile recorder se "newHscEnvEqWithImportPaths" hiePath
160+
case hieCheck of
161+
HieFileMissing -> return ()
162+
HieAlreadyIndexed -> return ()
163+
CouldNotLoadHie _e -> return ()
164+
DoIndexing hash hie ->
165+
indexHieFile se hiePath (FakeFile Nothing) hash hie
162166
toFilePath :: ModuleName -> FilePath
163167
toFilePath = separateDirectories . prettyModuleName
164168
where
@@ -214,7 +218,7 @@ instance Ord Package where
214218

215219
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
216220
newHscEnvEqPreserveImportPaths
217-
:: ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
221+
:: Recorder (WithPriority Log) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
218222
newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing
219223

220224
-- | 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)