|
| 1 | +module Development.IDE.Core.Dependencies |
| 2 | + ( indexDependencyHieFiles |
| 3 | + ) where |
| 4 | + |
| 5 | +import Control.Concurrent.STM (atomically) |
| 6 | +import Control.Concurrent.STM.TQueue (writeTQueue) |
| 7 | +import Control.Monad (unless, void) |
| 8 | +import Data.Foldable (traverse_) |
| 9 | +import qualified Data.Map as Map |
| 10 | +import Data.Maybe (isNothing) |
| 11 | +import Data.Set (Set) |
| 12 | +import qualified Data.Set as Set |
| 13 | +import Development.IDE.Core.Compile (indexHieFile) |
| 14 | +import Development.IDE.Core.Rules (HieFileCheck(..), Log, checkHieFile) |
| 15 | +import Development.IDE.Core.Shake (HieDbWriter(indexQueue), ShakeExtras(hiedbWriter, lspEnv, withHieDb)) |
| 16 | +import qualified Development.IDE.GHC.Compat as GHC |
| 17 | +import Development.IDE.Types.Location (NormalizedFilePath, toNormalizedFilePath') |
| 18 | +import Ide.Logger (Recorder, WithPriority) |
| 19 | +import HieDb (SourceFile(FakeFile), lookupPackage, removeDependencySrcFiles) |
| 20 | +import Language.LSP.Server (resRootPath) |
| 21 | +import System.Directory (doesDirectoryExist) |
| 22 | +import System.FilePath ((</>), (<.>)) |
| 23 | + |
| 24 | +newtype Package = Package GHC.UnitInfo deriving Eq |
| 25 | +instance Ord Package where |
| 26 | + compare (Package u1) (Package u2) = compare (GHC.unitId u1) (GHC.unitId u2) |
| 27 | + |
| 28 | +-- indexDependencyHieFiles gets all of the direct and transitive dependencies |
| 29 | +-- from the HscEnv and indexes their HIE files in the HieDb. |
| 30 | +indexDependencyHieFiles :: Recorder (WithPriority Log) -> ShakeExtras -> GHC.HscEnv -> IO () |
| 31 | +indexDependencyHieFiles recorder se hscEnv = do |
| 32 | + -- Check whether the .hls directory exists. |
| 33 | + dotHlsDirExists <- maybe (pure False) doesDirectoryExist mHlsDir |
| 34 | + -- If the .hls directory does not exits, it may have been deleted. |
| 35 | + -- In this case, delete the indexed source files for all |
| 36 | + -- dependencies that are already indexed. |
| 37 | + unless dotHlsDirExists deleteMissingDependencySources |
| 38 | + -- Index all dependency HIE files in the HieDb database. |
| 39 | + void $ Map.traverseWithKey indexPackageHieFiles packagesWithModules |
| 40 | + where |
| 41 | + mHlsDir :: Maybe FilePath |
| 42 | + mHlsDir = do |
| 43 | + projectDir <- resRootPath =<< lspEnv se |
| 44 | + pure $ projectDir </> ".hls" |
| 45 | + -- Add the deletion of dependency source files from the |
| 46 | + -- HieDb database to the database write queue. |
| 47 | + deleteMissingDependencySources :: IO () |
| 48 | + deleteMissingDependencySources = |
| 49 | + atomically $ writeTQueue (indexQueue $ hiedbWriter se) $ |
| 50 | + \withHieDb -> |
| 51 | + withHieDb $ \db -> |
| 52 | + removeDependencySrcFiles db |
| 53 | + -- Index all of the modules in a package (a Unit). |
| 54 | + indexPackageHieFiles :: Package -> [GHC.Module] -> IO () |
| 55 | + indexPackageHieFiles (Package package) modules = do |
| 56 | + let pkgLibDir :: FilePath |
| 57 | + pkgLibDir = case GHC.unitLibraryDirs package of |
| 58 | + [] -> "" |
| 59 | + (libraryDir : _) -> libraryDir |
| 60 | + -- Cabal puts the HIE files for a package in the |
| 61 | + -- extra-compilation-artifacts directory, provided |
| 62 | + -- it is compiled with the -fwrite-ide-info ghc option. |
| 63 | + hieDir :: FilePath |
| 64 | + hieDir = pkgLibDir </> "extra-compilation-artifacts" |
| 65 | + unit :: GHC.Unit |
| 66 | + unit = GHC.RealUnit $ GHC.Definite $ GHC.unitId package |
| 67 | + -- Check if we have already indexed this package. |
| 68 | + moduleRows <- withHieDb se $ \db -> |
| 69 | + lookupPackage db unit |
| 70 | + case moduleRows of |
| 71 | + -- There are no modules from this package in the database, |
| 72 | + -- so go ahead and index all the modules. |
| 73 | + [] -> traverse_ (indexModuleHieFile hieDir) modules |
| 74 | + -- There are modules from this package in the database, |
| 75 | + -- so assume all the modules have already been indexed |
| 76 | + -- and do nothing. |
| 77 | + _ -> return () |
| 78 | + indexModuleHieFile :: FilePath -> GHC.Module -> IO () |
| 79 | + indexModuleHieFile hieDir m = do |
| 80 | + let hiePath :: NormalizedFilePath |
| 81 | + hiePath = toNormalizedFilePath' $ |
| 82 | + hieDir </> GHC.moduleNameSlashes (GHC.moduleName m) <.> "hie" |
| 83 | + -- Check that the module HIE file has correctly loaded. If there |
| 84 | + -- was some problem loading it, or if it has already been indexed |
| 85 | + -- (which shouldn't happen because we check whether each package |
| 86 | + -- has been indexed), then do nothing. Otherwise, call the |
| 87 | + -- indexHieFile function from Core.Compile. |
| 88 | + hieCheck <- checkHieFile recorder se "newHscEnvEqWithImportPaths" hiePath |
| 89 | + case hieCheck of |
| 90 | + HieFileMissing -> return () |
| 91 | + HieAlreadyIndexed -> return () |
| 92 | + CouldNotLoadHie _e -> return () |
| 93 | + DoIndexing hash hie -> |
| 94 | + -- At this point there is no source file for the HIE file, |
| 95 | + -- so the HieDb.SourceFile we give is FakeFile Nothing. |
| 96 | + indexHieFile se hiePath (FakeFile Nothing) hash hie |
| 97 | + packagesWithModules :: Map.Map Package [GHC.Module] |
| 98 | + packagesWithModules = Map.fromSet getModulesForPackage packages |
| 99 | + packages :: Set Package |
| 100 | + packages = Set.fromList |
| 101 | + $ map Package |
| 102 | + $ Map.elems |
| 103 | + -- Take only the packages in the unitInfoMap that are direct |
| 104 | + -- or transitive dependencies. |
| 105 | + $ Map.filterWithKey (\uid _ -> uid `Set.member` dependencyIds) unitInfoMap |
| 106 | + where |
| 107 | + unitInfoMap :: GHC.UnitInfoMap |
| 108 | + unitInfoMap = GHC.getUnitInfoMap hscEnv |
| 109 | + dependencyIds :: Set GHC.UnitId |
| 110 | + dependencyIds = |
| 111 | + calculateTransitiveDependencies unitInfoMap directDependencyIds directDependencyIds |
| 112 | + directDependencyIds :: Set GHC.UnitId |
| 113 | + directDependencyIds = Set.fromList |
| 114 | + $ map GHC.toUnitId |
| 115 | + $ GHC.explicitUnits |
| 116 | + $ GHC.unitState hscEnv |
| 117 | + |
| 118 | +-- calculateTransitiveDependencies finds the UnitId keys in the UnitInfoMap |
| 119 | +-- that are dependencies or transitive dependencies. |
| 120 | +calculateTransitiveDependencies :: GHC.UnitInfoMap -> Set GHC.UnitId -> Set GHC.UnitId -> Set GHC.UnitId |
| 121 | +calculateTransitiveDependencies unitInfoMap allDependencies newDepencencies |
| 122 | + -- If there are no new dependencies, we have found them all, |
| 123 | + -- so return allDependencies |
| 124 | + | Set.null newDepencencies = allDependencies |
| 125 | + -- Otherwise recursively add any dependencies of the newDepencencies |
| 126 | + -- that are not in allDependencies already. |
| 127 | + | otherwise = calculateTransitiveDependencies unitInfoMap nextAll nextNew |
| 128 | + where |
| 129 | + nextAll :: Set GHC.UnitId |
| 130 | + nextAll = Set.union allDependencies nextNew |
| 131 | + -- Get the dependencies of the newDependencies. Then the nextNew depencencies |
| 132 | + -- will be the set difference of the dependencies we have so far (allDependencies), |
| 133 | + -- and the dependencies of the newDepencencies. |
| 134 | + nextNew :: Set GHC.UnitId |
| 135 | + nextNew = flip Set.difference allDependencies |
| 136 | + $ Set.unions |
| 137 | + $ map (Set.fromList . GHC.unitDepends) |
| 138 | + $ Map.elems |
| 139 | + $ Map.filterWithKey (\uid _ -> uid `Set.member` newDepencencies) unitInfoMap |
| 140 | + |
| 141 | +getModulesForPackage :: Package -> [GHC.Module] |
| 142 | +getModulesForPackage (Package package) = |
| 143 | + map makeModule allModules |
| 144 | + where |
| 145 | + allModules :: [GHC.ModuleName] |
| 146 | + allModules = map fst |
| 147 | + -- The modules with a Just value in the tuple |
| 148 | + -- are from other packages. These won't have |
| 149 | + -- an HIE file in this package, and should be |
| 150 | + -- covered by the transitive dependencies. |
| 151 | + ( filter (isNothing . snd) |
| 152 | + $ GHC.unitExposedModules package |
| 153 | + ) |
| 154 | + ++ GHC.unitHiddenModules package |
| 155 | + makeModule :: GHC.ModuleName |
| 156 | + -> GHC.Module |
| 157 | + makeModule = GHC.mkModule (GHC.unitInfoId package) |
0 commit comments