@@ -7,26 +7,16 @@
77
88module Main(main) where
99
10−import Linker (initDynLinker)
11−import Data.IORef
12−import NameCache
13−import Packages
14−import Module
1510import Arguments
16−import Control.Concurrent.Async
11+import Data.Maybe
12+import Data.List.Extra
13+import System.FilePath
1714import Control.Concurrent.Extra
1815import Control.Exception
1916import Control.Monad.Extra
2017import Control.Monad.IO.Class
2118import Data.Default
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
19+import System.Time.Extra
3020import Development.IDE.Core.Debouncer
3121import Development.IDE.Core.FileStore
3222import Development.IDE.Core.OfInterest
@@ -43,39 +33,25 @@ import Development.IDE.GHC.Util
4333import Development.IDE.Plugin
4434import Development.IDE.Plugin.Completions as Completions
4535import Development.IDE.Plugin.CodeAction as CodeAction
36+import qualified Data.Text as T
37+import qualified Data.Text.IO as T
4638import qualified Language.Haskell.LSP.Core as LSP
4739import Language.Haskell.LSP.Messages
48−import Language.Haskell.LSP.Types
49−import Data.Aeson (ToJSON(toJSON))
40+import Language.Haskell.LSP.Types (LspId(IdInt))
41+import Data.Version
5042import Development.IDE.LSP.LanguageServer
5143import qualified System.Directory.Extra as IO
5244import System.Environment
5345import System.IO
5446import System.Exit
55−import System.FilePath
56−import System.Directory
57−import System.Time.Extra
58−import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
5947import Paths_ghcide
6048import Development.GitRev
61−import Development.Shake (Action, action)
49+import Development.Shake (Action, Rules, action)
6250import qualified Data.HashSet as HashSet
63−import qualified Data.HashMap.Strict as HM
6451import qualified Data.Map.Strict as Map
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
52+import HIE.Bios
53+import Rules
54+import RuleTypes
7955
8056ghcideVersion :: IO String
8157ghcideVersion = do
@@ -121,14 +97,15 @@ main = do
12197 runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
12298 t <- t
12399 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
124− let options = (defaultIdeOptions $ loadSessionShake dir)
100+ let options = (defaultIdeOptions $ loadSession dir)
125101 { optReportProgress = clientSupportsProgress caps
126102 , optShakeProfiling = argsShakeProfiling
127103 , optTesting = argsTesting
128104 , optThreads = argsThreads
105+ , optInterfaceLoadingDiagnostics = argsTesting
129106 }
130107 debouncer <- newAsyncDebouncer
131− initialise caps (mainRule >> pluginRules plugins >> action kick)
108+ initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
132109 getLspId event (logger minBound) debouncer options vfs
133110 else do
134111 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -138,32 +115,55 @@ main = do
138115 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
139116 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
140117
141− putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
118+ putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
142119 files <- expandFiles (argFiles ++ ["." | null argFiles])
143120 -- LSP works with absolute file paths, so try and behave similarly
144121 files <- nubOrd <$> mapM IO.canonicalizePath files
145122 putStrLn $ "Found " ++ show (length files) ++ " files"
146123
147− putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
124+ putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
148125 cradles <- mapM findCradle files
149126 let ucradles = nubOrd cradles
150127 let n = length ucradles
151128 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
152− putStrLn "\nStep 3/4: Initializing the IDE"
129+ sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
130+ let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
131+ putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
132+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
133+ when (isNothing x) $ print cradle
134+ putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
135+ opts <- getComponentOptions cradle
136+ createSession opts
137+
138+ putStrLn "\nStep 5/6: Initializing the IDE"
153139 vfs <- makeVFSHandle
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"
140+ let cradlesToSessions = Map.fromList $ zip ucradles sessions
141+ let filesToCradles = Map.fromList $ zip files cradles
142+ let grab file = fromMaybe (head sessions) $ do
143+ cradle <- Map.lookup file filesToCradles
144+ Map.lookup cradle cradlesToSessions
145+
146+ let options =
147+ (defaultIdeOptions $ return $ return . grab)
148+ { optShakeProfiling = argsShakeProfiling }
149+ ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
150+
151+ putStrLn "\nStep 6/6: Type checking the files"
158152 setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
159− results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
153+ results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files
160154 let (worked, failed) = partition fst $ zip (map isJust results) files
161155 when (failed /= []) $
162156 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
163157
164158 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
165159 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
166− return ()
160+
161+ unless (null failed) exitFailure
162+
163+cradleRules :: Rules ()
164+cradleRules = do
165+ loadGhcSession
166+ cradleToSession
167167
168168expandFiles :: [FilePath] -> IO [FilePath]
169169expandFiles = concatMapM $ \x -> do
@@ -190,405 +190,23 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
190190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
191191showEvent lock e = withLock lock $ print e
192192
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)
193+loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
194+loadSession dir = liftIO $ do
195+ cradleLoc <- memoIO $ \v -> do
196+ res <- findCradle v
197+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
198+ -- try and normalise that
199+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
200+ res' <- traverse IO.makeAbsolute res
201+ return $ normalise <$> res'
202+ let session :: Maybe FilePath -> Action HscEnvEq
203+ session file = do
204+ -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
205+ let cradle = toNormalizedFilePath' $ fromMaybe dir file
206+ use_ LoadCradle cradle
207+ return $ \file -> session =<< liftIO (cradleLoc file)
403208
404209
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−
592210-- | Memoize an IO function, with the characteristics:
593211--
594212-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
@@ -605,79 +223,3 @@ memoIO op = do
605223 res <- onceFork $ op k
606224 return (Map.insert k res mp, res)
607225 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