Call indexHieFile in newHscEnvEq

nlander · nlander · commit 16719c9a7405 · 2023-07-03T08:42:53.000-05:00
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -887,34 +887,32 @@ spliceExpressions Splices{..} =
 -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we
 -- can just increment the 'indexCompleted' TVar and exit.
 --
-indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO ()
-indexHieFile se mod_summary srcPath !hash hf = do
+indexHieFile :: ShakeExtras -> NormalizedFilePath -> HieDb.SourceFile -> Util.Fingerprint -> Compat.HieFile -> IO ()
+indexHieFile se hiePath sourceFile !hash hf = do
  IdeOptions{optProgressStyle} <- getIdeOptionsIO se
  atomically $ do
   pending <- readTVar indexPending
-  case HashMap.lookup srcPath pending of
+  case HashMap.lookup hiePath pending of
     Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled
     _ -> do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
-      modifyTVar' indexPending $ HashMap.insert srcPath hash
+      modifyTVar' indexPending $ HashMap.insert hiePath hash
       writeTQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
           pending <- readTVar indexPending
-          pure $ case HashMap.lookup srcPath pending of
+          pure $ case HashMap.lookup hiePath pending of
             Nothing          -> False
             -- If the hash in the pending list doesn't match the current hash, then skip
             Just pendingHash -> pendingHash /= hash
         unless newerScheduled $ do
           -- Using bracket, so even if an exception happen during withHieDb call,
           -- the `post` (which clean the progress indicator) will still be called.
           bracket_ (pre optProgressStyle) post $
-            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
+            withHieDb (\db -> HieDb.addRefsFromLoaded db (fromNormalizedFilePath hiePath) sourceFile hash hf')
   where
-    mod_location    = ms_location mod_summary
-    targetPath      = Compat.ml_hie_file mod_location
     HieDbWriter{..} = hiedbWriter se
 
     -- Get a progress token to report progress and update it for the current file
@@ -978,15 +976,15 @@ indexHieFile se mod_summary srcPath !hash hf = do
       mdone <- atomically $ do
         -- Remove current element from pending
         pending <- stateTVar indexPending $
-          dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath
+          dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) hiePath
         modifyTVar' indexCompleted (+1)
         -- If we are done, report and reset completed
         whenMaybe (HashMap.null pending) $
           swapTVar indexCompleted 0
       whenJust (lspEnv se) $ \env -> LSP.runLspT env $
         when (coerce $ ideTesting se) $
           LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $
-            toJSON $ fromNormalizedFilePath srcPath
+            toJSON $ fromNormalizedFilePath hiePath
       whenJust mdone $ \done ->
         modifyVar_ indexProgressToken $ \tok -> do
           whenJust (lspEnv se) $ \env -> LSP.runLspT env $
@@ -1007,7 +1005,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =
       GHC.mkHieFile' mod_summary exports ast source
     atomicFileWrite se targetPath $ flip GHC.writeHieFile hf
     hash <- Util.getFileHash targetPath
-    indexHieFile se mod_summary srcPath hash hf
+    indexHieFile se (toNormalizedFilePath' targetPath) (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf
   where
     dflags       = hsc_dflags hscEnv
     mod_location = ms_location mod_summary
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -876,7 +876,7 @@ getModIfaceFromDiskAndIndexRule recorder =
         -- can just re-index the file we read from disk
         Right hf -> liftIO $ do
           logWith recorder Logger.Debug $ LogReindexingHieFile f
-          indexHieFile se ms f hash hf
+          indexHieFile se (toNormalizedFilePath' hie_loc) (HieDb.RealFile $ fromNormalizedFilePath f) hash hf
 
   return (Just x)
 
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs
@@ -24,6 +24,8 @@ module Development.IDE.GHC.Compat.Units (
     -- * UnitInfo
     UnitInfo,
     unitExposedModules,
+    unitLibraryDirs,
+    UnitInfo.unitId,
     unitDepends,
     unitHaddockInterfaces,
     unitInfoId,
@@ -273,6 +275,9 @@ preloadClosureUs = State.preloadClosure . unitState
 preloadClosureUs = const ()
 #endif
 
+unitLibraryDirs :: UnitInfo -> [FilePath]
+unitLibraryDirs = fmap ST.unpack . UnitInfo.unitLibraryDirs
+
 unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)]
 unitExposedModules ue =
 #if MIN_VERSION_ghc(9,0,0)
diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs
@@ -18,17 +18,23 @@ import           Control.DeepSeq                 (force)
 import           Control.Exception               (evaluate, mask, throwIO)
 import           Control.Monad.Extra             (eitherM, join, mapMaybeM)
 import           Data.Either                     (fromRight)
+import qualified Data.Map                        as Map
 import           Data.Set                        (Set)
 import qualified Data.Set                        as Set
+import qualified Data.Text                       as T
 import           Data.Unique                     (Unique)
 import qualified Data.Unique                     as Unique
-import           Development.IDE.Core.Shake      (ShakeExtras)
+import           Development.IDE.Core.Compile    (indexHieFile, loadHieFile)
+import           Development.IDE.Core.Shake      (ShakeExtras(ideNc, logger), mkUpdater)
 import           Development.IDE.GHC.Compat
 import qualified Development.IDE.GHC.Compat.Util as Maybes
 import           Development.IDE.GHC.Error       (catchSrcErrors)
 import           Development.IDE.GHC.Util        (lookupPackageConfig)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap)
+import           Development.IDE.Types.Location  (toNormalizedFilePath')
+import qualified Development.IDE.Types.Logger    as Logger
+import           HieDb                           (SourceFile(FakeFile))
 import           OpenTelemetry.Eventlog          (withSpan)
 import           System.Directory                (makeAbsolute)
 import           System.FilePath
@@ -71,6 +77,10 @@ newHscEnvEq cradlePath se hscEnv0 deps = do
 
     newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) se hscEnv deps
 
+newtype UnitInfoOrd = UnitInfoOrd UnitInfo deriving Eq
+instance Ord UnitInfoOrd where
+  compare (UnitInfoOrd u1) (UnitInfoOrd u2) = compare (unitId u1) (unitId u2)
+
 newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
 newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
 
@@ -83,25 +93,70 @@ newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
         -- compute the package imports
         let pkgst   = unitState hscEnv
             depends = explicitUnits pkgst
-            modules =
-                [ m
-                | d        <- depends
-                , Just pkg <- [lookupPackageConfig d hscEnv]
-                , (modName, maybeOtherPkgMod) <- unitExposedModules pkg
-                , let m = case maybeOtherPkgMod of
-                        -- When module is re-exported from another package,
-                        -- the origin module is represented by value in Just
-                        Just otherPkgMod -> otherPkgMod
-                        Nothing          -> mkModule (unitInfoId pkg) modName
-                ]
-
-            doOne m = do
+            packages = [ pkg
+                       | d <- depends
+                       , Just pkg <- [lookupPackageConfig d hscEnv]
+                       ]
+            modules = Map.fromSet
+                (\(UnitInfoOrd pkg) ->
+                  [ m
+                  | (modName, maybeOtherPkgMod) <- unitExposedModules pkg
+                  , let m = case maybeOtherPkgMod of
+                          -- When module is re-exported from another package,
+                          -- the origin module is represented by value in Just
+                          Just otherPkgMod -> otherPkgMod
+                          Nothing          -> mkModule (unitInfoId pkg) modName
+                  ]
+                )
+                (Set.fromList $ map UnitInfoOrd packages)
+
+            logPackage :: UnitInfo -> IO ()
+            logPackage pkg = Logger.logDebug (logger se) $ "\n\n\n!!!!!!!!!!!! hscEnvEq :\n"
+              <> T.pack (concatMap show $ unitLibraryDirs pkg)
+              <> "\n!!!!!!!!!!!!!!!!!!!!!!\n\n\n"
+            doOnePackage :: UnitInfoOrd -> [Module] -> IO [ModIface]
+            doOnePackage (UnitInfoOrd pkg) ms = do
+              let pkgLibDir :: FilePath
+                  pkgLibDir = case unitLibraryDirs pkg of
+                    [] -> ""
+                    (libraryDir : _) -> libraryDir
+                  hieDir :: FilePath
+                  hieDir = pkgLibDir </> "extra-compliation-artifacts"
+              logPackage pkg
+              mapMaybeM (doOne hieDir) ms
+
+            doOne :: FilePath -> Module -> IO (Maybe ModIface)
+            doOne hieDir m = do
+                let toFilePath :: ModuleName -> FilePath
+                    toFilePath = separateDirectories . prettyModuleName
+                      where
+                        separateDirectories :: FilePath -> FilePath
+                        separateDirectories moduleNameString =
+                          case breakOnDot moduleNameString of
+                            [] -> ""
+                            ms -> foldr1 (</>) ms
+                        breakOnDot :: FilePath -> [FilePath]
+                        breakOnDot = words . map replaceDotWithSpace
+                        replaceDotWithSpace :: Char -> Char
+                        replaceDotWithSpace '.' = ' '
+                        replaceDotWithSpace c = c
+                        prettyModuleName :: ModuleName -> String
+                        prettyModuleName = filter (/= '"')
+                          . concat
+                          . drop 1
+                          . words
+                          . show
+                    hiePath :: FilePath
+                    hiePath = hieDir </> toFilePath (moduleName m) ++ ".hie"
                 modIface <- initIfaceLoad hscEnv $
                     loadInterface "" m (ImportByUser NotBoot)
-                return $ case modIface of
-                    Maybes.Failed    _r -> Nothing
-                    Maybes.Succeeded mi -> Just mi
-        modIfaces <- mapMaybeM doOne modules
+                case modIface of
+                    Maybes.Failed    _r -> return Nothing
+                    Maybes.Succeeded mi -> do
+                      hie <- loadHieFile (mkUpdater $ ideNc se) hiePath
+                      indexHieFile se (toNormalizedFilePath' hiePath) (FakeFile Nothing) (mi_src_hash mi) hie
+                      return $ Just mi
+        modIfaces <- concat . Map.elems <$> Map.traverseWithKey doOnePackage modules
         return $ createExportsMap modIfaces
 
     -- similar to envPackageExports, evaluated lazily
