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