git.iko.soy/ghcide
on a410abc 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-lib" GHC hiding (parseModule, typecheckModule)
33import qualified "ghc-lib-parser" Parser
34import "ghc-lib-parser" Lexer
35import "ghc-lib-parser" Bag
37import qualified "ghc-lib" GHC
38import "ghc-lib-parser" Panic
39import "ghc-lib-parser" GhcMonad
40import "ghc-lib" GhcPlugins as GHC hiding (PackageState, fst3, (<>))
41import qualified "ghc-lib" HeaderInfo as Hdr
42import "ghc-lib" MkIface
43import "ghc-lib-parser" NameCache
44import "ghc-lib-parser" StringBuffer as SB
45import "ghc-lib" TidyPgm
46import "ghc-lib-parser" InstEnv
47import "ghc-lib-parser" 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, [(String, String)])]
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 ([Diagnostic], 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 [Diagnostic] [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 ([Diagnostic], 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 [Diagnostic] 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 ([Diagnostic], 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 [Diagnostic] 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 [Diagnostic] m ([Diagnostic], 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 [Diagnostic] 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, [(String, String)])] -> 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 [Diagnostic] 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