Skip to content

Commit 174b330

Browse files
pepeiborrapepeiborra
committed
clean up
1 parent 533b0bf commit 174b330

File tree

3 files changed

+36
-38
lines changed

3 files changed

+36
-38
lines changed

‎ghcide/.hlint.yaml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,7 @@
133133
# Things that are unsafe in Haskell base library
134134
- {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}
135135
- {name: unsafeDupablePerformIO, within: []}
136-
- {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]}
136+
- {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Core.Compile, Development.IDE.Types.Shake]}
137137
# Things that are a bit dangerous in the GHC API
138138
- {name: nameModule, within: []}
139139

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

Lines changed: 30 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ module Development.IDE.Core.Compile
3030
, setupFinderCache
3131
, getDocsBatch
3232
, lookupName
33-
) where
33+
,mergeEnvs) where
3434

3535
import Development.IDE.Core.Preprocessor
3636
import Development.IDE.Core.RuleTypes
@@ -89,8 +89,10 @@ import System.Directory
8989
import System.FilePath
9090
import System.IO.Extra (fixIO, newTempFileWithin)
9191

92+
-- GHC API imports
9293
-- GHC API imports
9394
import GHC (GetDocsFailure (..),
95+
mgModSummaries,
9496
parsedSource)
9597

9698
import Control.Concurrent.Extra
@@ -100,11 +102,14 @@ import Data.Binary
100102
import Data.Coerce
101103
import Data.Functor
102104
import qualified Data.HashMap.Strict as HashMap
105+
import Data.Map (Map)
103106
import Data.Tuple.Extra (dupe)
104107
import Data.Unique as Unique
105108
import Development.IDE.Core.Tracing (withTrace)
109+
import GhcPlugins (FinderCache)
106110
import qualified Language.LSP.Server as LSP
107111
import qualified Language.LSP.Types as LSP
112+
import Unsafe.Coerce
108113

109114
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
110115
parseModule
@@ -686,6 +691,30 @@ loadModulesHome mod_infos e =
686691
where
687692
mod_name = moduleName . mi_module . hm_iface
688693

694+
-- Merge the HPTs, module graphs and FinderCaches
695+
mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
696+
mergeEnvs env extraModSummaries extraMods envs = do
697+
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
698+
let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries
699+
ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims
700+
newFinderCache <- newIORef $
701+
foldl'
702+
(\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
703+
$ zip ims ifrs
704+
return $ loadModulesHome extraMods $ env{
705+
hsc_HPT = foldMap hsc_HPT envs,
706+
hsc_FC = newFinderCache,
707+
hsc_mod_graph = mkModuleGraph $ extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)
708+
}
709+
where
710+
-- required because 'FinderCache':
711+
-- 1) doesn't have a 'Monoid' instance,
712+
-- 2) is abstract and doesn't export constructors
713+
-- To work around this, we coerce to the underlying type
714+
-- To remove this, I plan to upstream the missing Monoid instance
715+
concatFC :: [FinderCache] -> FinderCache
716+
concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))
717+
689718
withBootSuffix :: HscSource -> ModLocation -> ModLocation
690719
withBootSuffix HsBootFile = addBootSuffixLocnOut
691720
withBootSuffix _ = id

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

Lines changed: 5 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -87,8 +87,6 @@ import Data.IORef
8787
import Data.IntMap.Strict (IntMap)
8888
import qualified Data.IntMap.Strict as IntMap
8989
import Data.List
90-
import Data.List.Extra (nubOrdOn)
91-
import Data.Map (Map)
9290
import qualified Data.Map as M
9391
import Data.Maybe
9492
import qualified Data.Rope.UTF16 as Rope
@@ -135,7 +133,6 @@ import Development.IDE.Types.Options
135133
import GHC.Generics (Generic)
136134
import GHC.IO.Encoding
137135
import qualified GHC.LanguageExtensions as LangExt
138-
import GhcPlugins (FinderCache, mgModSummaries)
139136
import qualified HieDb
140137
import Ide.Plugin.Config
141138
import qualified Language.LSP.Server as LSP
@@ -151,7 +148,6 @@ import Ide.Plugin.Properties (HasProperty,
151148
import Ide.PluginUtils (configForPlugin)
152149
import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
153150
PluginId)
154-
import Unsafe.Coerce (unsafeCoerce)
155151

156152
-- | This is useful for rules to convert rules that can only produce errors or
157153
-- a result into the more general IdeResult type that supports producing
@@ -703,48 +699,21 @@ ghcSessionDepsDefinition file = do
703699
deps <- mapMaybe (fmap artifactFilePath . snd) <$> use_ GetLocatedImports file
704700
mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps
705701

706-
depSessions <- uses_ GhcSessionDeps deps
707-
session' <- liftIO $ mergeEnvs hsc mss $ map hscEnv depSessions
702+
depSessions <- map hscEnv <$> uses_ GhcSessionDeps deps
708703
let uses_th_qq =
709704
xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
710705
dflags = ms_hspp_opts ms
711706
ifaces <- if uses_th_qq
712707
then uses_ GetModIface deps
713708
else uses_ GetModIfaceWithoutLinkable deps
714709

715-
let session'' = loadModulesHome inLoadOrder $ session'{
716-
hsc_HPT = foldMap (hsc_HPT . hscEnv) depSessions
717-
}
710+
let inLoadOrder = reverse $ map hirHomeMod ifaces
711+
session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
718712
-- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
719713
-- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
720714
-- Long-term we might just want to change the order returned by GetDependencies
721-
inLoadOrder = reverse $ map hirHomeMod ifaces
722-
723-
liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session'' []
724-
725-
-- Merge the HPTs, module graphs and FinderCaches
726-
mergeEnvs :: HscEnv -> [ModSummary] -> [HscEnv] -> IO HscEnv
727-
mergeEnvs env mss envs = do
728-
prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
729-
let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) mss
730-
ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
731-
newFinderCache <- newIORef $
732-
foldl'
733-
(\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
734-
$ zip ims ifrs
735-
return env{
736-
hsc_HPT = foldMap hsc_HPT envs,
737-
hsc_FC = newFinderCache,
738-
hsc_mod_graph = mkModuleGraph $ mss ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)
739-
}
740-
where
741-
-- required because 'FinderCache':
742-
-- 1) doesn't have a 'Monoid' instance,
743-
-- 2) is abstract and doesn't export constructors
744-
-- To work around this, we coerce to the underlying type
745-
-- To remove this, I plan to upstream the missing Monoid instance
746-
concatFC :: [FinderCache] -> FinderCache
747-
concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))
715+
716+
liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' []
748717

749718
-- | Load a iface from disk, or generate it if there isn't one or it is out of date
750719
-- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.

0 commit comments

Comments
 (0)