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