@@ -7,16 +7,26 @@
77
88module Main(main) where
99
10+import Linker (initDynLinker)
11+import Data.IORef
12+import NameCache
13+import Packages
14+import Module
1015import Arguments
11−import Data.Maybe
12−import Data.List.Extra
13−import System.FilePath
16+import Control.Concurrent.Async
1417import Control.Concurrent.Extra
1518import Control.Exception
1619import Control.Monad.Extra
1720import Control.Monad.IO.Class
1821import Data.Default
19−import System.Time.Extra
22+import Data.Either
23+import Data.Function
24+import Data.List.Extra
25+import Data.Maybe
26+import qualified Data.Text as T
27+import qualified Data.Text.IO as T
28+import Data.Time.Clock (UTCTime)
29+import Data.Version
2030import Development.IDE.Core.Debouncer
2131import Development.IDE.Core.FileStore
2232import Development.IDE.Core.OfInterest
@@ -33,25 +43,39 @@ import Development.IDE.GHC.Util
3343import Development.IDE.Plugin
3444import Development.IDE.Plugin.Completions as Completions
3545import Development.IDE.Plugin.CodeAction as CodeAction
36−import qualified Data.Text as T
37−import qualified Data.Text.IO as T
3846import qualified Language.Haskell.LSP.Core as LSP
3947import Language.Haskell.LSP.Messages
40−import Language.Haskell.LSP.Types (LspId(IdInt))
41−import Data.Version
48+import Language.Haskell.LSP.Types
49+import Data.Aeson (ToJSON(toJSON))
4250import Development.IDE.LSP.LanguageServer
4351import qualified System.Directory.Extra as IO
4452import System.Environment
4553import System.IO
4654import System.Exit
55+import System.FilePath
56+import System.Directory
57+import System.Time.Extra
58+import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
4759import Paths_ghcide
4860import Development.GitRev
49−import Development.Shake (Action, Rules, action)
61+import Development.Shake (Action, action)
5062import qualified Data.HashSet as HashSet
63+import qualified Data.HashMap.Strict as HM
5164import qualified Data.Map.Strict as Map
52−import HIE.Bios
53−import Rules
54−import RuleTypes
65+import qualified Crypto.Hash.SHA1 as H
66+import qualified Data.ByteString.Char8 as B
67+import Data.ByteString.Base16 (encode)
68+import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))
69+import GhcMonad
70+import HscTypes (HscEnv(..), ic_dflags)
71+import GHC hiding (def)
72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
73+import Data.Either.Extra
74+
75+import HIE.Bios.Cradle
76+import HIE.Bios.Types
77+
78+import Utils
5579
5680ghcideVersion :: IO String
5781ghcideVersion = do
@@ -97,14 +121,14 @@ main = do
97121 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
98122 t <- t
99123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
100− let options = (defaultIdeOptions $ loadSession dir)
124+ let options = (defaultIdeOptions $ loadSessionShake dir)
101125 { optReportProgress = clientSupportsProgress caps
102126 , optShakeProfiling = argsShakeProfiling
103127 , optTesting = argsTesting
104128 , optThreads = argsThreads
105129 }
106130 debouncer <- newAsyncDebouncer
107− initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
131+ initialise caps (mainRule >> pluginRules plugins >> action kick)
108132 getLspId event (logger minBound) debouncer options vfs
109133 else do
110134 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -114,55 +138,32 @@ main = do
114138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
115139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
116140
117− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
118142 files <- expandFiles (argFiles ++ ["." | null argFiles])
119143 -- LSP works with absolute file paths, so try and behave similarly
120144 files <- nubOrd <$> mapM IO.canonicalizePath files
121145 putStrLn $ "Found " ++ show (length files) ++ " files"
122146
123− putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
147+ putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
124148 cradles <- mapM findCradle files
125149 let ucradles = nubOrd cradles
126150 let n = length ucradles
127151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
128− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
129− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
130− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
131− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
132− when (isNothing x) $ print cradle
133− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
134− opts <- getComponentOptions cradle
135− createSession opts
136−
137− putStrLn "\nStep 5/6: Initializing the IDE"
152+ putStrLn "\nStep 3/4: Initializing the IDE"
138153 vfs <- makeVFSHandle
139− let cradlesToSessions = Map.fromList $ zip ucradles sessions
140− let filesToCradles = Map.fromList $ zip files cradles
141− let grab file = fromMaybe (head sessions) $ do
142− cradle <- Map.lookup file filesToCradles
143− Map.lookup cradle cradlesToSessions
144−
145− let options =
146− (defaultIdeOptions $ return $ return . grab)
147− { optShakeProfiling = argsShakeProfiling }
148− ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
149−
150− putStrLn "\nStep 6/6: Type checking the files"
154+ debouncer <- newAsyncDebouncer
155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
156+
157+ putStrLn "\nStep 4/4: Type checking the files"
151158 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
152− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files
159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
153160 let (worked, failed) = partition fst $ zip (map isJust results) files
154161 when (failed /= []) $
155162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
156163
157164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
158165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
159−
160− unless (null failed) exitFailure
161−
162−cradleRules :: Rules ()
163−cradleRules = do
164− loadGhcSession
165− cradleToSession
166+ return ()
166167
167168expandFiles :: [FilePath] -> IO [FilePath]
168169expandFiles = concatMapM $ \x -> do
@@ -189,23 +190,405 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
189190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
190191showEvent lock e = withLock lock $ print e
191192
192−loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
193−loadSession dir = liftIO $ do
194− cradleLoc <- memoIO $ \v -> do
195− res <- findCradle v
196− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
197− -- try and normalise that
198− -- e.g. see https://github.com/digital-asset/ghcide/issues/126
199− res' <- traverse IO.makeAbsolute res
200− return $ normalise <$> res'
201− let session :: Maybe FilePath -> Action HscEnvEq
202− session file = do
203− -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
204− let cradle = toNormalizedFilePath' $ fromMaybe dir file
205− use_ LoadCradle cradle
206− return $ \file -> session =<< liftIO (cradleLoc file)
193+
194+-- | Run the specific cradle on a specific FilePath via hie-bios.
195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
196+cradleToSessionOpts cradle file = do
197+ let showLine s = putStrLn ("> " ++ s)
198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file
199+ case cradleRes of
200+ CradleSuccess r -> pure (Right r)
201+ CradleFail err -> return (Left [err])
202+ -- For the None cradle perhaps we still want to report an Info
203+ -- message about the fact that the file is being ignored.
204+ CradleNone -> return (Left [])
205+
206+emptyHscEnv :: IO HscEnv
207+emptyHscEnv = do
208+ libdir <- getLibdir
209+ env <- runGhc (Just libdir) getSession
210+ initDynLinker env
211+ pure env
212+
213+-- | Convert a target to a list of potential absolute paths.
214+-- A TargetModule can be anywhere listed by the supplied include
215+-- directories
216+-- A target file is a relative path but with a specific prefix so just need
217+-- to canonicalise it.
218+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]
219+targetToFile is (TargetModule mod) = do
220+ let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]
221+ exts = ["hs", "hs-boot", "lhs"]
222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
223+targetToFile _ (TargetFile f _) = do
224+ f' <- canonicalizePath f
225+ return [toNormalizedFilePath' f']
226+
227+setNameCache :: IORef NameCache -> HscEnv -> HscEnv
228+setNameCache nc hsc = hsc { hsc_NC = nc }
229+
230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
231+loadSessionShake fp = do
232+ se <- getShakeExtras
233+ IdeOptions{optTesting} <- getIdeOptions
234+ res <- liftIO $ loadSession optTesting se fp
235+ return (fmap liftIO res)
236+
237+-- | This is the key function which implements multi-component support. All
238+-- components mapping to the same hie.yaml file are mapped to the same
239+-- HscEnv which is updated as new components are discovered.
240+loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
241+loadSession optTesting ShakeExtras{logger, eventer} dir = do
242+ -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
243+ hscEnvs <- newVar Map.empty :: IO (Var HieMap)
244+ -- Mapping from a Filepath to HscEnv
245+ fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
246+
247+ -- This caches the mapping from Mod.hs -> hie.yaml
248+ cradleLoc <- memoIO $ \v -> do
249+ res <- findCradle v
250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
251+ -- try and normalise that
252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
253+ res' <- traverse IO.makeAbsolute res
254+ return $ normalise <$> res'
255+
256+ -- Create a new HscEnv from a hieYaml root and a set of options
257+ -- If the hieYaml file already has an HscEnv, the new component is
258+ -- combined with the components in the old HscEnv into a new HscEnv
259+ -- which contains the union.
260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)
261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])
262+ packageSetup (hieYaml, cfp, opts) = do
263+ -- Parse DynFlags for the newly discovered component
264+ hscEnv <- emptyHscEnv
265+ (df, targets) <- evalGhcEnv hscEnv $
266+ setOptions opts (hsc_dflags hscEnv)
267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
268+ -- Now lookup to see whether we are combining with an existing HscEnv
269+ -- or making a new one. The lookup returns the HscEnv and a list of
270+ -- information about other components loaded into the HscEnv
271+ -- (unitId, DynFlag, Targets)
272+ modifyVar hscEnvs $ \m -> do
273+ -- Just deps if there's already an HscEnv
274+ -- Nothing is it's the first time we are making an HscEnv
275+ let oldDeps = Map.lookup hieYaml m
276+ let -- Add the raw information about this component to the list
277+ -- We will modify the unitId and DynFlags used for
278+ -- compilation but these are the true source of
279+ -- information.
280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info
281+ : maybe [] snd oldDeps
282+ -- Get all the unit-ids for things in this component
283+ inplace = map rawComponentUnitId new_deps
284+
285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
286+ -- Remove all inplace dependencies from package flags for
287+ -- components in this HscEnv
288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
289+ let prefix = show rawComponentUnitId
290+ -- See Note [Avoiding bad interface files]
291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2
292+ -- The final component information, mostly the same but the DynFlags don't
293+ -- contain any packages which are also loaded
294+ -- into the same component.
295+ pure $ ComponentInfo rawComponentUnitId
296+ processed_df
297+ uids
298+ rawComponentTargets
299+ rawComponentFP
300+ rawComponentCOptions
301+ rawComponentDependencyInfo
302+ -- Make a new HscEnv, we have to recompile everything from
303+ -- scratch again (for now)
304+ -- It's important to keep the same NameCache though for reasons
305+ -- that I do not fully understand
306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
307+ hscEnv <- case oldDeps of
308+ Nothing -> emptyHscEnv
309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
310+ newHscEnv <-
311+ -- Add the options for the current component to the HscEnv
312+ evalGhcEnv hscEnv $ do
313+ _ <- setSessionDynFlags df
314+ getSession
315+ -- Modify the map so the hieYaml now maps to the newly created
316+ -- HscEnv
317+ -- Returns
318+ -- . the new HscEnv so it can be used to modify the
319+ -- FilePath -> HscEnv map (fileToFlags)
320+ -- . The information for the new component which caused this cache miss
321+ -- . The modified information (without -inplace flags) for
322+ -- existing packages
323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
324+
325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
326+ session (hieYaml, cfp, opts) = do
327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
328+ -- Make a map from unit-id to DynFlags, this is used when trying to
329+ -- resolve imports. (especially PackageImports)
330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
331+
332+ -- For each component, now make a new HscEnvEq which contains the
333+ -- HscEnv for the hie.yaml file but the DynFlags for that component
334+
335+ -- New HscEnv for the component in question, returns the new HscEnvEq and
336+ -- a mapping from FilePath to the newly created HscEnvEq.
337+ let new_cache = newComponentCache logger hscEnv uids
338+ (cs, res) <- new_cache new
339+ -- Modified cache targets for everything else in the hie.yaml file
340+ -- which now uses the same EPS and so on
341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps
342+ modifyVar_ fileToFlags $ \var -> do
343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
344+
345+ return (fst res)
346+
347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
348+ consultCradle hieYaml cfp = do
349+ when optTesting $ eventer $ notifyCradleLoaded cfp
350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
352+ eopts <- cradleToSessionOpts cradle cfp
353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)
354+ case eopts of
355+ -- The cradle gave us some options so get to work turning them
356+ -- into and HscEnv.
357+ Right opts -> do
358+ session (hieYaml, toNormalizedFilePath' cfp, opts)
359+ -- Failure case, either a cradle error or the none cradle
360+ Left err -> do
361+ dep_info <- getDependencyInfo (maybeToList hieYaml)
362+ let ncfp = toNormalizedFilePath' cfp
363+ let res = (map (renderCradleError ncfp) err, Nothing)
364+ modifyVar_ fileToFlags $ \var -> do
365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
366+ return res
367+
368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]
369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
370+ sessionOpts (hieYaml, file) = do
371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
372+ cfp <- canonicalizePath file
373+ case HM.lookup (toNormalizedFilePath' cfp) v of
374+ Just (opts, old_di) -> do
375+ deps_ok <- checkDependencyInfo old_di
376+ if not deps_ok
377+ then do
378+ -- If the dependencies are out of date then clear both caches and start
379+ -- again.
380+ modifyVar_ fileToFlags (const (return Map.empty))
381+ -- Keep the same name cache
382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
383+ consultCradle hieYaml cfp
384+ else return opts
385+ Nothing -> consultCradle hieYaml cfp
386+
387+ dummyAs <- async $ return (error "Uninitialised")
388+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))
389+ -- The main function which gets options for a file. We only want one of these running
390+ -- at a time. Therefore the IORef contains the currently running cradle, if we try
391+ -- to get some more options then we wait for the currently running action to finish
392+ -- before attempting to do so.
393+ let getOptions :: FilePath -> IO (IdeResult HscEnvEq)
394+ getOptions file = do
395+ hieYaml <- cradleLoc file
396+ sessionOpts (hieYaml, file)
397+ return $ \file -> do
398+ join $ mask_ $ modifyVar runningCradle $ \as -> do
399+ -- If the cradle is not finished, then wait for it to finish.
400+ void $ wait as
401+ as <- async $ getOptions file
402+ return (as, wait as)
207403
208404
405+
406+-- | Create a mapping from FilePaths to HscEnvEqs
407+newComponentCache
408+ :: Logger
409+ -> HscEnv
410+ -> [(InstalledUnitId, DynFlags)]
411+ -> ComponentInfo
412+ -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))
413+newComponentCache logger hsc_env uids ci = do
414+ let df = componentDynFlags ci
415+ let hscEnv' = hsc_env { hsc_dflags = df
416+ , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
417+
418+ versionMismatch <- checkGhcVersion
419+ henv <- case versionMismatch of
420+ Just mismatch -> return mismatch
421+ Nothing -> newHscEnvEq hscEnv' uids
422+ let res = (([], Just henv), componentDependencyInfo ci)
423+ logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))
424+
425+ let is = importPaths df
426+ ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci)
427+ -- A special target for the file which caused this wonderful
428+ -- component to be created. In case the cradle doesn't list all the targets for
429+ -- the component, in which case things will be horribly broken anyway.
430+ -- Otherwise, we will immediately attempt to reload this module which
431+ -- causes an infinite loop and high CPU usage.
432+ let special_target = (componentFP ci, res)
433+ let xs = map (,res) ctargets
434+ return (special_target:xs, res)
435+
436+{- Note [Avoiding bad interface files]
437+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
438+Originally, we set the cache directory for the various components once
439+on the first occurrence of the component.
440+This works fine if these components have no references to each other,
441+but you have components that depend on each other, the interface files are
442+updated for each component.
443+After restarting the session and only opening the component that depended
444+on the other, suddenly the interface files of this component are stale.
445+However, from the point of view of `ghcide`, they do not look stale,
446+thus, not regenerated and the IDE shows weird errors such as:
447+```
448+typecheckIface
449+Declaration for Rep_ClientRunFlags
450+Axiom branches Rep_ClientRunFlags:
451+ Failed to load interface for ‘Distribution.Simple.Flag’
452+ Use -v to see a list of the files searched for.
453+```
454+and
455+```
456+expectJust checkFamInstConsistency
457+CallStack (from HasCallStack):
458+ error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes
459+ expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
460+```
461+
462+To mitigate this, we set the cache directory for each component dependent
463+on the components of the current `HscEnv`, additionally to the component options
464+of the respective components.
465+Assume two components, c1, c2, where c2 depends on c1, and the options of the
466+respective components are co1, co2.
467+If we want to load component c2, followed by c1, we set the cache directory for
468+each component in this way:
469+
470+ * Load component c2
471+ * (Cache Directory State)
472+ - name of c2 + co2
473+ * Load component c1
474+ * (Cache Directory State)
475+ - name of c2 + name of c1 + co2
476+ - name of c2 + name of c1 + co1
477+
478+Overall, we created three cache directories. If we opened c1 first, then we
479+create a fourth cache directory.
480+This makes sure that interface files are always correctly updated.
481+
482+Since this causes a lot of recompilation, we only update the cache-directory,
483+if the dependencies of a component have really changed.
484+E.g. when you load two executables, they can not depend on each other. They
485+should be filtered out, such that we dont have to re-compile everything.
486+-}
487+
488+-- | Set the cache-directory based on the ComponentOptions and a list of
489+-- internal packages.
490+-- For the exact reason, see Note [Avoiding bad interface files].
491+setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags
492+setCacheDir logger prefix hscComponents comps dflags = do
493+ cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)
494+ liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir
495+ pure $ dflags
496+ & setHiDir cacheDir
497+ & setDefaultHieDir cacheDir
498+
499+
500+renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
501+renderCradleError nfp (CradleError _ec t) =
502+ ideErrorText nfp (T.unlines (map T.pack t))
503+
504+-- See Note [Multi Cradle Dependency Info]
505+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
506+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])
507+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
508+
509+-- This is pristine information about a component
510+data RawComponentInfo = RawComponentInfo
511+ { rawComponentUnitId :: InstalledUnitId
512+ -- | Unprocessed DynFlags. Contains inplace packages such as libraries.
513+ -- We do not want to use them unprocessed.
514+ , rawComponentDynFlags :: DynFlags
515+ -- | All targets of this components.
516+ , rawComponentTargets :: [Target]
517+ -- | Filepath which caused the creation of this component
518+ , rawComponentFP :: NormalizedFilePath
519+ -- | Component Options used to load the component.
520+ , rawComponentCOptions :: ComponentOptions
521+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
522+ -- to last modification time. See Note [Multi Cradle Dependency Info].
523+ , rawComponentDependencyInfo :: DependencyInfo
524+ }
525+
526+-- This is processed information about the component, in particular the dynflags will be modified.
527+data ComponentInfo = ComponentInfo
528+ { componentUnitId :: InstalledUnitId
529+ -- | Processed DynFlags. Does not contain inplace packages such as local
530+ -- libraries. Can be used to actually load this Component.
531+ , componentDynFlags :: DynFlags
532+ -- | Internal units, such as local libraries, that this component
533+ -- is loaded with. These have been extracted from the original
534+ -- ComponentOptions.
535+ , componentInternalUnits :: [InstalledUnitId]
536+ -- | All targets of this components.
537+ , componentTargets :: [Target]
538+ -- | Filepath which caused the creation of this component
539+ , componentFP :: NormalizedFilePath
540+ -- | Component Options used to load the component.
541+ , componentCOptions :: ComponentOptions
542+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
543+ -- to last modification time. See Note [Multi Cradle Dependency Info]
544+ , componentDependencyInfo :: DependencyInfo
545+ }
546+
547+-- | Check if any dependency has been modified lately.
548+checkDependencyInfo :: DependencyInfo -> IO Bool
549+checkDependencyInfo old_di = do
550+ di <- getDependencyInfo (Map.keys old_di)
551+ return (di == old_di)
552+
553+-- Note [Multi Cradle Dependency Info]
554+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555+-- Why do we implement our own file modification tracking here?
556+-- The primary reason is that the custom caching logic is quite complicated and going into shake
557+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to
558+-- use shake rules rather than IO but eventually gave up.
559+
560+-- | Computes a mapping from a filepath to its latest modification date.
561+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead
562+-- of letting shake take care of it.
563+getDependencyInfo :: [FilePath] -> IO DependencyInfo
564+getDependencyInfo fs = Map.fromList <$> mapM do_one fs
565+
566+ where
567+ tryIO :: IO a -> IO (Either IOException a)
568+ tryIO = try
569+
570+ do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
571+ do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)
572+
573+-- | This function removes all the -package flags which refer to packages we
574+-- are going to deal with ourselves. For example, if a executable depends
575+-- on a library component, then this function will remove the library flag
576+-- from the package flags for the executable
577+--
578+-- There are several places in GHC (for example the call to hptInstances in
579+-- tcRnImports) which assume that all modules in the HPT have the same unit
580+-- ID. Therefore we create a fake one and give them all the same unit id.
581+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
582+removeInplacePackages us df = (df { packageFlags = ps
583+ , thisInstalledUnitId = fake_uid }, uids)
584+ where
585+ (uids, ps) = partitionEithers (map go (packageFlags df))
586+ fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
587+ go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
588+ then Left (toInstalledUnitId u)
589+ else Right p
590+ go p = Right p
591+
209592-- | Memoize an IO function, with the characteristics:
210593--
211594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
@@ -222,3 +605,79 @@ memoIO op = do
222605 res <- onceFork $ op k
223606 return (Map.insert k res mp, res)
224607 Just res -> return (mp, res)
608+
609+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
610+setOptions (ComponentOptions theOpts compRoot _) dflags = do
611+ (dflags', targets) <- addCmdOpts theOpts dflags
612+ let dflags'' =
613+ -- disabled, generated directly by ghcide instead
614+ flip gopt_unset Opt_WriteInterface $
615+ -- disabled, generated directly by ghcide instead
616+ -- also, it can confuse the interface stale check
617+ dontWriteHieFiles $
618+ setIgnoreInterfacePragmas $
619+ setLinkerOptions $
620+ disableOptimisation $
621+ makeDynFlagsAbsolute compRoot dflags'
622+ -- initPackages parses the -package flags and
623+ -- sets up the visibility for each component.
624+ (final_df, _) <- liftIO $ initPackages dflags''
625+ return (final_df, targets)
626+
627+
628+-- we don't want to generate object code so we compile to bytecode
629+-- (HscInterpreted) which implies LinkInMemory
630+-- HscInterpreted
631+setLinkerOptions :: DynFlags -> DynFlags
632+setLinkerOptions df = df {
633+ ghcLink = LinkInMemory
634+ , hscTarget = HscNothing
635+ , ghcMode = CompManager
636+ }
637+
638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
639+setIgnoreInterfacePragmas df =
640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
641+
642+disableOptimisation :: DynFlags -> DynFlags
643+disableOptimisation df = updOptLevel 0 df
644+
645+setHiDir :: FilePath -> DynFlags -> DynFlags
646+setHiDir f d =
647+ -- override user settings to avoid conflicts leading to recompilation
648+ d { hiDir = Just f}
649+
650+getCacheDir :: String -> [String] -> IO FilePath
651+getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
652+ where
653+ -- Create a unique folder per set of different GHC options, assuming that each different set of
654+ -- GHC options will create incompatible interface files.
655+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
656+
657+-- | Sub directory for the cache path
658+cacheDir :: String
659+cacheDir = "ghcide"
660+
661+notifyCradleLoaded :: FilePath -> FromServerMessage
662+notifyCradleLoaded fp =
663+ NotCustomServer $
664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $
665+ toJSON fp
666+
667+cradleLoadedMethod :: T.Text
668+cradleLoadedMethod = "ghcide/cradle/loaded"
669+
670+ghcVersionChecker :: IO VersionCheck
671+ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))
672+
673+checkGhcVersion :: IO (Maybe HscEnvEq)
674+checkGhcVersion = do
675+ res <- ghcVersionChecker
676+ case res of
677+ Failure err -> do
678+ putStrLn $ "Error while checking GHC version: " ++ show err
679+ return Nothing
680+ Mismatch {..} ->
681+ return $ Just GhcVersionMismatch {..}
682+ _ ->
683+ return Nothing