git.iko.soy/ghcide
on bec100b help sign in
ghcide/src/Development/IDE/Functions/Compile.hs
504 lines 19 kB history raw
1-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE CPP #-}
8-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
10module Development.IDE.Functions.Compile
11 ( GhcModule(..)
12 , TcModuleResult(..)
13 , LoadPackageResult(..)
14 , getGhcDynFlags
15 , compileModule
16 , getSrcSpanInfos
17 , parseModule
18 , typecheckModule
19 , loadPackage
20 , computePackageDeps
21 , generatePackageState
22 ) where
24import Development.IDE.Functions.Warnings
25import Development.IDE.Types.Diagnostics
26import qualified Development.IDE.Functions.FindImports as FindImports
27import Development.IDE.Functions.GHCError
28import Development.IDE.Functions.SpanInfo
29import Development.IDE.UtilGHC
30import Development.IDE.Types.Options
32import HieBin
33import HieAst
35import GHC hiding (parseModule, typecheckModule)
36import qualified Parser
37import Lexer
38import Bag
40import qualified GHC
41import Panic
42import GhcMonad
43import GhcPlugins as GHC hiding (fst3, (<>))
44import qualified HeaderInfo as Hdr
45import MkIface
46import NameCache
47import StringBuffer as SB
48import TidyPgm
49import InstEnv
50import FamInstEnv
52import Control.DeepSeq
53import Control.Exception as E
54import Control.Monad
55import qualified Control.Monad.Trans.Except as Ex
56import Data.IORef
57import Data.List.Extra
58import Data.Maybe
59import Data.Tuple.Extra
60import qualified Data.Map.Strict as Map
61import Data.Time
62import Development.IDE.Types.SpanInfo
63import GHC.Generics (Generic)
64import System.FilePath
66-- | 'CoreModule' together with some additional information required for the
67-- conversion to DAML-LF.
68data GhcModule = GhcModule
69 { gmPath :: Maybe FilePath
70 , gmCore :: CoreModule
71 }
72 deriving (Generic, Show)
74instance NFData GhcModule
76-- | Contains the typechecked module and the OrigNameCache entry for
77-- that module.
78data TcModuleResult = TcModuleResult
79 { tmrModule :: TypecheckedModule
80 , tmrModInfo :: HomeModInfo
81 , tmrOccEnvName :: OccEnv Name
82 }
84-- | Contains the result of loading an interface. In particular the delta to the name cache.
85data LoadPackageResult = LoadPackageResult
86 { lprInstalledUnitId :: InstalledUnitId
87 , lprModuleEnv :: ModuleEnv (OccEnv Name)
88 , lprEps :: ExternalPackageState
89 }
91-- | Get source span info, used for e.g. AtPoint and Goto Definition.
92getSrcSpanInfos
93 :: IdeOptions
94 -> ParsedModule
95 -> PackageDynFlags
96 -> [(Located ModuleName, Maybe FilePath)]
97 -> TcModuleResult
98 -> IO [SpanInfo]
99getSrcSpanInfos opt mod packageState imports tc =
100 runGhcSession opt (Just mod) packageState
101 . getSpanInfo imports
102 $ tmrModule tc
105-- | Given a string buffer, return a pre-processed @ParsedModule@.
106parseModule
107 :: IdeOptions
108 -> PackageDynFlags
109 -> FilePath
110 -> (UTCTime, SB.StringBuffer)
111 -> IO ([FileDiagnostic], Maybe ParsedModule)
112parseModule opt@IdeOptions{..} packageState file =
113 fmap (either (, Nothing) (second Just)) . Ex.runExceptT .
114 -- We need packages since imports fail to resolve otherwise.
115 runGhcSessionExcept opt Nothing packageState . parseFileContents optPreprocessor file
117computePackageDeps ::
118 IdeOptions -> PackageDynFlags -> InstalledUnitId -> IO (Either [FileDiagnostic] [InstalledUnitId])
119computePackageDeps opts packageState iuid =
120 Ex.runExceptT $
121 runGhcSessionExcept opts Nothing packageState $
122 catchSrcErrors $ do
123 dflags <- hsc_dflags <$> getSession
124 liftIO $ depends <$> getPackage dflags iuid
126getPackage :: DynFlags -> InstalledUnitId -> IO PackageConfig
127getPackage dflags p =
128 case lookupInstalledPackage dflags p of
129 Nothing -> E.throwIO $ CmdLineError (missingPackageMsg p)
130 Just pkg -> return pkg
131 where
132 missingPackageMsg p = showSDoc dflags $ text "unknown package:" <+> ppr p
134-- | Typecheck a single module using the supplied dependencies and packages.
135typecheckModule
136 :: IdeOptions
137 -> ParsedModule
138 -> PackageDynFlags
139 -> UniqSupply
140 -> [TcModuleResult]
141 -> [LoadPackageResult]
142 -> ParsedModule
143 -> IO ([FileDiagnostic], Maybe TcModuleResult)
144typecheckModule opt mod packageState uniqSupply deps pkgs pm =
145 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
146 runGhcSessionExcept opt (Just mod) packageState $
147 catchSrcErrors $ do
148 setupEnv uniqSupply deps pkgs
149 (warnings, tcm) <- withWarnings "Typechecker" $ \tweak ->
150 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
151 tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
152 return (warnings, tcm2)
154-- | Load a pkg and populate the name cache and external package state.
155loadPackage ::
156 IdeOptions
157 -> PackageDynFlags
158 -> UniqSupply
159 -> [LoadPackageResult]
160 -> InstalledUnitId
161 -> IO (Either [FileDiagnostic] LoadPackageResult)
162loadPackage opt packageState us lps p =
163 Ex.runExceptT $
164 runGhcSessionExcept opt Nothing packageState $
165 catchSrcErrors $ do
166 setupEnv us [] lps
167 dflags <- hsc_dflags <$> getSession
168 exposedMods <- liftIO $ exposedModules <$> getPackage dflags p
169 let mods =
170 [ Module (DefiniteUnitId (DefUnitId p)) mod
171 | (mod, _mbParent) <- exposedMods
172 ]
173 forM_ mods $ \mod -> GHC.getModuleInfo mod
174 -- this populates the namecache and external package state
175 session <- getSession
176 modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
177 eps <- liftIO (readIORef $ hsc_EPS session)
178 pure $ LoadPackageResult p modEnv eps
180-- | Compile a single type-checked module to a 'CoreModule' value, or
181-- provide errors.
182compileModule
183 :: IdeOptions
184 -> ParsedModule
185 -> PackageDynFlags
186 -> UniqSupply
187 -> [TcModuleResult]
188 -> [LoadPackageResult]
189 -> TcModuleResult
190 -> IO ([FileDiagnostic], Maybe GhcModule)
191compileModule opt mod packageState uniqSupply deps pkgs tmr =
192 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
193 runGhcSessionExcept opt (Just mod) packageState $
194 catchSrcErrors $ do
195 setupEnv uniqSupply (deps ++ [tmr]) pkgs
197 let tm = tmrModule tmr
198 session <- getSession
199 (warnings,desugar) <- withWarnings "Desugarer" $ \tweak -> do
200 let pm = tm_parsed_module tm
201 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
202 let tm' = tm{tm_parsed_module = pm'}
203 GHC.dm_core_module <$> GHC.desugarModule tm'
205 -- give variables unique OccNames
206 (tidy, details) <- liftIO $ tidyProgram session desugar
208 let path = ml_hs_file $ ms_location $ pm_mod_summary $ tm_parsed_module tm
209 let core = CoreModule
210 (cg_module tidy)
211 (md_types details)
212 (cg_binds tidy)
213 (mg_safe_haskell desugar)
215 return (warnings, GhcModule path core)
217-- | Evaluate a GHC session using a new environment constructed with
218-- the supplied options.
219runGhcSessionExcept
220 :: IdeOptions
221 -> Maybe ParsedModule
222 -> PackageDynFlags
223 -> Ex.ExceptT e Ghc a
224 -> Ex.ExceptT e IO a
225runGhcSessionExcept opts mbMod pkg m =
226 Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
229getGhcDynFlags :: IdeOptions -> ParsedModule -> PackageDynFlags -> IO DynFlags
230getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
232-- | Evaluate a GHC session using a new environment constructed with
233-- the supplied options.
234runGhcSession
235 :: IdeOptions
236 -> Maybe ParsedModule
237 -> PackageDynFlags
238 -> Ghc a
239 -> IO a
240runGhcSession IdeOptions{..} = optRunGhcSession
242-- When we make a fresh GHC environment, the OrigNameCache comes already partially
243-- populated. So to be safe, we simply extend this one.
244mkNameCache :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m NameCache
245mkNameCache uniqSupply tms pkgs = do
246 session <- getSession
247 onc <- nsNames <$> liftIO (readIORef $ hsc_NC session)
248 return NameCache
249 { nsUniqs = uniqSupply
250 , nsNames = extendOrigNameCache' onc tms pkgs
251 }
253-- | Extend the name cache with the names from the typechecked home modules and the loaded packages.
254-- If we have two environments containing the same module we take the later one. We do this because
255-- the name cache comes prepopulated with modules from daml-prim and we overwrite those with our own
256-- daml-prim package.
257extendOrigNameCache' :: OrigNameCache -> [TcModuleResult] -> [LoadPackageResult] -> OrigNameCache
258extendOrigNameCache' onc tms pkgs = foldl (plusModuleEnv_C (\_x y -> y)) onc modEnvs
259 where
260 modEnvs =
261 mkModuleEnv
262 [(ms_mod $ tcModSummary $ tmrModule tm, tmrOccEnvName tm) | tm <- tms] :
263 [lprModuleEnv lm | lm <- pkgs]
265newtype WriteInterface = WriteInterface Bool
267mkTcModuleResult
268 :: GhcMonad m
269 => WriteInterface
270 -> TypecheckedModule
271 -> m TcModuleResult
272mkTcModuleResult (WriteInterface writeIface) tcm = do
273 session <- getSession
274 nc <- liftIO $ readIORef (hsc_NC session)
275 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
276 liftIO $ when writeIface $ do
277 writeIfaceFile (hsc_dflags session) (replaceExtension (file tcm) ".hi") iface
278 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
279 -- when we are building a package. It should be easily decoupable if that turns out to be
280 -- useful.
281 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
282 writeHieFile (replaceExtension (file tcm) ".hie") hieFile
283 let mod_info = HomeModInfo iface details Nothing
284 origNc = nsNames nc
285 case lookupModuleEnv origNc (tcmModule tcm) of
286 Nothing -> panic err
287 Just occ -> return $ TcModuleResult tcm mod_info occ
288 where
289 file = ms_hspp_file . tcModSummary
290 tcmModule = ms_mod . tcModSummary
291 (tcGblEnv, details) = tm_internals_ tcm
292 err = "Internal error : module not found in NameCache :" <>
293 moduleNameString (moduleName $ tcmModule tcm)
295tcModSummary :: TypecheckedModule -> ModSummary
296tcModSummary = pm_mod_summary . tm_parsed_module
298-- | Setup the environment that GHC needs according to our
299-- best understanding (!)
300setupEnv :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m ()
301setupEnv uniqSupply tms lps = do
302 session <- getSession
304 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
306 -- set the target and module graph in the session
307 let graph = mkModuleGraph mss
308 setSession session { hsc_mod_graph = graph }
310 -- Make modules available for others that import them,
311 -- by putting them in the finder cache.
312 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
313 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
314 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
315 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
316 $ zip ims ifrs
318 -- construct a new NameCache
319 nc' <- mkNameCache uniqSupply tms lps
320 -- update the name cache
321 liftIO $ modifyIORef (hsc_NC session) $ const nc'
322 -- update the external package state
323 liftIO $ modifyIORef (hsc_EPS session) (updateEps lps)
324 -- load dependent modules, which must be in topological order.
325 mapM_ loadModuleHome tms
327-- | Update the external package state given the loaded package results.
328updateEps :: [LoadPackageResult] -> ExternalPackageState -> ExternalPackageState
329updateEps lps eps =
330 eps
331 { eps_inst_env = newInstEnv
332 , eps_PIT = newPIT
333 , eps_PTE = newPTE
334 , eps_rule_base = newRuleBase
335 , eps_complete_matches = newCompleteMatches
336 , eps_fam_inst_env = newFamInst
337 , eps_ann_env = newAnnEnv
338 , eps_mod_fam_inst_env = newModFamInstEnv
339 }
340 where
341 (newInstEnv, (newPIT, (newPTE, (newRuleBase, (newCompleteMatches, (newFamInst, (newAnnEnv, newModFamInstEnv))))))) =
342 foldl
343 (\(instEnv, (pit, (pte, (ruleBase, (completeMatches, (famInst, (annEnv, modFamInstEnv))))))) ->
344 (instEnv `extendInstEnvList0`) ***
345 (pit `plusModuleEnv`) ***
346 (pte `plusTypeEnv`) ***
347 (ruleBase `unionRuleBase`) ***
348 (completeMatches `extendCompleteMatchMap`) ***
349 (famInst `extendFamInstEnvList`) ***
350 (annEnv `plusAnnEnv`) *** (modFamInstEnv `plusModuleEnv`))
351 ( emptyInstEnv
352 , ( emptyPackageIfaceTable
353 , ( emptyTypeEnv
354 , ( emptyRuleBase
355 , (emptyUFM, (emptyFamInstEnv, (emptyAnnEnv, emptyModuleEnv)))))))
356 [ ( instEnvElts $ eps_inst_env e
357 , ( eps_PIT e
358 , ( eps_PTE e
359 , ( eps_rule_base e
360 , ( concat $ eltsUFM $ eps_complete_matches e
361 , ( famInstEnvElts $ eps_fam_inst_env e
362 , (eps_ann_env e, eps_mod_fam_inst_env e)))))))
363 | p <- lps
364 , let e = lprEps p
365 ]
367 -- TODO (drsk): This is necessary because the EPS that we store include the results of
368 -- previously loaded packages and we end up adding instances several times to the environment.
369 -- It would be better to have pure delta stored in the LoadPackageResult, such that it
370 -- contains only identities/instances/names coming from that specific loaded package, but I
371 -- failed so far in computing the correct delta.
372 extendInstEnvList0 instEnv0 clsInsts =
373 extendInstEnvList emptyInstEnv $
374 nubOrdOn is_dfun_name $ instEnvElts instEnv0 ++ clsInsts
376-- | Load a module, quickly. Input doesn't need to be desugared.
377-- A module must be loaded before dependent modules can be typechecked.
378-- This variant of loadModuleHome will *never* cause recompilation, it just
379-- modifies the session.
380loadModuleHome
381 :: (GhcMonad m)
382 => TcModuleResult
383 -> m ()
384loadModuleHome tmr = modifySession $ \e ->
385 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
386 where
387 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
388 mod_info = tmrModInfo tmr
389 mod = ms_mod_name ms
391-- | Produce a module summary from a StringBuffer.
392getModSummaryFromBuffer
393 :: GhcMonad m
394 => FilePath
395 -> (SB.StringBuffer, UTCTime)
396 -> DynFlags
397 -> GHC.ParsedSource
398 -> Ex.ExceptT [FileDiagnostic] m ModSummary
399getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do
400 (modName, imports) <- FindImports.getImportsParsed dflags parsed
402 let modLoc = ModLocation
403 { ml_hs_file = Just fp
404 , ml_hi_file = replaceExtension fp "hi"
405 , ml_obj_file = replaceExtension fp "o"
406#ifndef USE_GHC
407 , ml_hie_file = replaceExtension fp "hie"
408#endif
409 -- This does not consider the dflags configuration
410 -- (-osuf and -hisuf, object and hi dir.s).
411 -- However, we anyway don't want to generate them.
412 }
413 InstalledUnitId unitId = thisInstalledUnitId dflags
414 return $ ModSummary
415 { ms_mod = mkModule (fsToUnitId unitId) modName
416 , ms_location = modLoc
417 , ms_hs_date = fileDate
418 , ms_textual_imps = imports
419 , ms_hspp_file = fp
420 , ms_hspp_opts = dflags
421 , ms_hspp_buf = Just contents
423 -- defaults:
424 , ms_hsc_src = HsSrcFile
425 , ms_obj_date = Nothing
426 , ms_iface_date = Nothing
427#ifndef USE_GHC
428 , ms_hie_date = Nothing
429#endif
430 , ms_srcimps = [] -- source imports are not allowed
431 , ms_parsed_mod = Nothing
432 }
434-- | Given a buffer, flags, file path and module summary, produce a
435-- parsed module (or errors) and any parse warnings.
436parseFileContents
437 :: GhcMonad m
438 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
439 -> FilePath -- ^ the filename (for source locations)
440 -> (UTCTime, SB.StringBuffer) -- ^ Haskell module source text (full Unicode is supported)
441 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
442parseFileContents preprocessor filename (time, contents) = do
443 let loc = mkRealSrcLoc (mkFastString filename) 1 1
444 dflags <- parsePragmasIntoDynFlags filename contents
445 case unP Parser.parseModule (mkPState dflags contents loc) of
446#ifdef USE_GHC
447 PFailed _ logMsg msgErr ->
448 Ex.throwE $ mkErrorDoc dflags locErr msgErr
449#else
450 PFailed s ->
451 Ex.throwE $ toDiagnostics dflags $ snd $ getMessages s dflags
452#endif
453 POk pst rdr_module ->
454 let hpm_annotations =
455 (Map.fromListWith (++) $ annotations pst,
456 Map.fromList ((noSrcSpan,comment_q pst)
457 :annotations_comments pst))
458 (warns,_) = getMessages pst dflags
459 in
460 do
461 let (errs, parsed) = preprocessor rdr_module
462 unless (null errs) $ Ex.throwE $ mkErrors dflags errs
463 ms <- getModSummaryFromBuffer filename (contents, time) dflags parsed
464 let pm =
465 ParsedModule {
466 pm_mod_summary = ms
467 , pm_parsed_source = parsed
468 , pm_extra_src_files=[] -- src imports not allowed
469 , pm_annotations = hpm_annotations
470 }
471 warnings = mapMaybe (mkDiag dflags "Parser") $ bagToList warns
472 pure (warnings, pm)
475-- | This reads the pragma information directly from the provided buffer.
476parsePragmasIntoDynFlags
477 :: GhcMonad m
478 => FilePath
479 -> SB.StringBuffer
480 -> Ex.ExceptT [FileDiagnostic] m DynFlags
481parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
482 dflags0 <- getSessionDynFlags
483 let opts = Hdr.getOptions dflags0 contents fp
484 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
485 return dflags
487generatePackageState :: [FilePath] -> Bool -> [(String, ModRenaming)] -> IO PackageDynFlags
488generatePackageState paths hideAllPkgs pkgImports = do
489 let dflags = setPackageImports hideAllPkgs pkgImports $ setPackageDbs paths fakeDynFlags
490 (newDynFlags, _) <- initPackages dflags
491 pure $ getPackageDynFlags newDynFlags
493-- | Run something in a Ghc monad and catch the errors (SourceErrors and
494-- compiler-internal exceptions like Panic or InstallationError).
495catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [FileDiagnostic] m a
496catchSrcErrors ghcM = do
497 dflags <- getDynFlags
498 Ex.ExceptT $
499 handleGhcException (ghcExceptionToDiagnostics dflags) $
500 handleSourceError (sourceErrorToDiagnostics dflags) $
501 Right <$> ghcM
502 where
503 ghcExceptionToDiagnostics dflags = return . Left . mkErrorsGhcException dflags
504 sourceErrorToDiagnostics dflags = return . Left . toDiagnostics dflags . srcErrorMessages