Skip to content

Commit cfa1b3e

Browse files
nlandernlander
committed
Factor out loading ModIfaces
1 parent 16719c9 commit cfa1b3e

File tree

1 file changed

+92
-72
lines changed

1 file changed

+92
-72
lines changed

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

Lines changed: 92 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -16,8 +16,9 @@ import Control.Concurrent.Async (Async, async, waitCatch)
1616
import Control.Concurrent.Strict (modifyVar, newVar)
1717
import Control.DeepSeq (force)
1818
import Control.Exception (evaluate, mask, throwIO)
19-
import Control.Monad.Extra (eitherM, join, mapMaybeM)
19+
import Control.Monad.Extra (eitherM, join, mapMaybeM, void)
2020
import Data.Either (fromRight)
21+
import Data.Foldable (traverse_)
2122
import qualified Data.Map as Map
2223
import Data.Set (Set)
2324
import qualified Data.Set as Set
@@ -77,88 +78,20 @@ newHscEnvEq cradlePath se hscEnv0 deps = do
7778

7879
newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) se hscEnv deps
7980

80-
newtype UnitInfoOrd = UnitInfoOrd UnitInfo deriving Eq
81-
instance Ord UnitInfoOrd where
82-
compare (UnitInfoOrd u1) (UnitInfoOrd u2) = compare (unitId u1) (unitId u2)
83-
8481
newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> ShakeExtras -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq
8582
newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
8683

87-
let dflags = hsc_dflags hscEnv
84+
indexDependencyHieFiles
8885

8986
envUnique <- Unique.newUnique
9087

9188
-- it's very important to delay the package exports computation
9289
envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do
9390
-- compute the package imports
94-
let pkgst = unitState hscEnv
95-
depends = explicitUnits pkgst
96-
packages = [ pkg
97-
| d <- depends
98-
, Just pkg <- [lookupPackageConfig d hscEnv]
99-
]
100-
modules = Map.fromSet
101-
(\(UnitInfoOrd pkg) ->
102-
[ m
103-
| (modName, maybeOtherPkgMod) <- unitExposedModules pkg
104-
, let m = case maybeOtherPkgMod of
105-
-- When module is re-exported from another package,
106-
-- the origin module is represented by value in Just
107-
Just otherPkgMod -> otherPkgMod
108-
Nothing -> mkModule (unitInfoId pkg) modName
109-
]
110-
)
111-
(Set.fromList $ map UnitInfoOrd packages)
112-
113-
logPackage :: UnitInfo -> IO ()
114-
logPackage pkg = Logger.logDebug (logger se) $ "\n\n\n!!!!!!!!!!!! hscEnvEq :\n"
115-
<> T.pack (concatMap show $ unitLibraryDirs pkg)
116-
<> "\n!!!!!!!!!!!!!!!!!!!!!!\n\n\n"
117-
doOnePackage :: UnitInfoOrd -> [Module] -> IO [ModIface]
118-
doOnePackage (UnitInfoOrd pkg) ms = do
119-
let pkgLibDir :: FilePath
120-
pkgLibDir = case unitLibraryDirs pkg of
121-
[] -> ""
122-
(libraryDir : _) -> libraryDir
123-
hieDir :: FilePath
124-
hieDir = pkgLibDir </> "extra-compliation-artifacts"
125-
logPackage pkg
126-
mapMaybeM (doOne hieDir) ms
127-
128-
doOne :: FilePath -> Module -> IO (Maybe ModIface)
129-
doOne hieDir m = do
130-
let toFilePath :: ModuleName -> FilePath
131-
toFilePath = separateDirectories . prettyModuleName
132-
where
133-
separateDirectories :: FilePath -> FilePath
134-
separateDirectories moduleNameString =
135-
case breakOnDot moduleNameString of
136-
[] -> ""
137-
ms -> foldr1 (</>) ms
138-
breakOnDot :: FilePath -> [FilePath]
139-
breakOnDot = words . map replaceDotWithSpace
140-
replaceDotWithSpace :: Char -> Char
141-
replaceDotWithSpace '.' = ' '
142-
replaceDotWithSpace c = c
143-
prettyModuleName :: ModuleName -> String
144-
prettyModuleName = filter (/= '"')
145-
. concat
146-
. drop 1
147-
. words
148-
. show
149-
hiePath :: FilePath
150-
hiePath = hieDir </> toFilePath (moduleName m) ++ ".hie"
151-
modIface <- initIfaceLoad hscEnv $
152-
loadInterface "" m (ImportByUser NotBoot)
153-
case modIface of
154-
Maybes.Failed _r -> return Nothing
155-
Maybes.Succeeded mi -> do
156-
hie <- loadHieFile (mkUpdater $ ideNc se) hiePath
157-
indexHieFile se (toNormalizedFilePath' hiePath) (FakeFile Nothing) (mi_src_hash mi) hie
158-
return $ Just mi
159-
modIfaces <- concat . Map.elems <$> Map.traverseWithKey doOnePackage modules
91+
modIfaces <- concat . Map.elems <$> loadPackagesWithModIFaces
16092
return $ createExportsMap modIfaces
16193

94+
let dflags = hsc_dflags hscEnv
16295
-- similar to envPackageExports, evaluated lazily
16396
envVisibleModuleNames <- onceAsync $
16497
fromRight Nothing
@@ -168,6 +101,93 @@ newHscEnvEqWithImportPaths envImportPaths se hscEnv deps = do
168101
(evaluate . force . Just $ listVisibleModuleNames hscEnv)
169102

170103
return HscEnvEq{..}
104+
where
105+
indexDependencyHieFiles :: IO ()
106+
indexDependencyHieFiles = do
107+
packagesWithModIfaces <- loadPackagesWithModIFaces
108+
void $ Map.traverseWithKey indexPackageHieFiles packagesWithModIfaces
109+
logPackage :: UnitInfo -> IO ()
110+
logPackage package = Logger.logDebug (logger se) $ "\n\n\n!!!!!!!!!!!! hscEnvEq :\n"
111+
<> T.pack (concatMap show $ unitLibraryDirs package)
112+
<> "\n!!!!!!!!!!!!!!!!!!!!!!\n\n\n"
113+
indexPackageHieFiles :: Package -> [ModIface] -> IO ()
114+
indexPackageHieFiles (Package package) modIfaces = do
115+
let pkgLibDir :: FilePath
116+
pkgLibDir = case unitLibraryDirs package of
117+
[] -> ""
118+
(libraryDir : _) -> libraryDir
119+
hieDir :: FilePath
120+
hieDir = pkgLibDir </> "extra-compilation-artifacts"
121+
logPackage package
122+
traverse_ (indexModuleHieFile hieDir) modIfaces
123+
logModule :: FilePath -> IO ()
124+
logModule hiePath = Logger.logDebug (logger se) $ "\n\n\n!!!!!!!!!!!! hscEnvEq :\n"
125+
<> T.pack hiePath
126+
<> "\n!!!!!!!!!!!!!!!!!!!!!!\n\n\n"
127+
indexModuleHieFile :: FilePath -> ModIface -> IO ()
128+
indexModuleHieFile hieDir modIface = do
129+
let hiePath :: FilePath
130+
hiePath = hieDir </> toFilePath (moduleName $ mi_module modIface) ++ ".hie"
131+
logModule hiePath
132+
hie <- loadHieFile (mkUpdater $ ideNc se) hiePath
133+
indexHieFile se (toNormalizedFilePath' hiePath) (FakeFile Nothing) (mi_src_hash modIface) hie
134+
toFilePath :: ModuleName -> FilePath
135+
toFilePath = separateDirectories . prettyModuleName
136+
where
137+
separateDirectories :: FilePath -> FilePath
138+
separateDirectories moduleNameString =
139+
case breakOnDot moduleNameString of
140+
[] -> ""
141+
ms -> foldr1 (</>) ms
142+
breakOnDot :: FilePath -> [FilePath]
143+
breakOnDot = words . map replaceDotWithSpace
144+
replaceDotWithSpace :: Char -> Char
145+
replaceDotWithSpace '.' = ' '
146+
replaceDotWithSpace c = c
147+
prettyModuleName :: ModuleName -> String
148+
prettyModuleName = filter (/= '"')
149+
. concat
150+
. drop 1
151+
. words
152+
. show
153+
loadModIFace :: Module -> IO (Maybe ModIface)
154+
loadModIFace m = do
155+
modIface <- initIfaceLoad hscEnv $
156+
loadInterface "" m (ImportByUser NotBoot)
157+
return $ case modIface of
158+
Maybes.Failed _r -> Nothing
159+
Maybes.Succeeded mi -> Just mi
160+
loadPackagesWithModIFaces :: IO (Map.Map Package [ModIface])
161+
loadPackagesWithModIFaces = Map.traverseWithKey
162+
(const $ mapMaybeM loadModIFace) packagesWithModules
163+
packagesWithModules :: Map.Map Package [Module]
164+
packagesWithModules = Map.fromSet getModulesForPackage packages
165+
packageState :: UnitState
166+
packageState = unitState hscEnv
167+
dependencies :: [Unit]
168+
dependencies = explicitUnits packageState
169+
packages :: Set Package
170+
packages = Set.fromList
171+
$ map Package
172+
[ package
173+
| d <- dependencies
174+
, Just package <- [lookupPackageConfig d hscEnv]
175+
]
176+
getModulesForPackage :: Package -> [Module]
177+
getModulesForPackage (Package package) =
178+
[ m
179+
| (modName, maybeOtherPkgMod) <- unitExposedModules package
180+
, let m = case maybeOtherPkgMod of
181+
-- When module is re-exported from another package,
182+
-- the origin module is represented by value in Just
183+
Just otherPkgMod -> otherPkgMod
184+
Nothing -> mkModule (unitInfoId package) modName
185+
]
186+
187+
newtype Package = Package UnitInfo deriving Eq
188+
instance Ord Package where
189+
compare (Package u1) (Package u2) = compare (unitId u1) (unitId u2)
190+
171191

172192
-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
173193
newHscEnvEqPreserveImportPaths

0 commit comments

Comments
 (0)