git.iko.soy/ghcide
on 0452205 help sign in
ghcide/src/Development/IDE/Core/Compile.hs
457 lines 17 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.Core.Compile
11 ( GhcModule(..)
12 , TcModuleResult(..)
13 , LoadPackageResult(..)
14 , getGhcDynFlags
15 , compileModule
16 , getSrcSpanInfos
17 , parseModule
18 , typecheckModule
19 , loadPackage
20 , computePackageDeps
21 ) where
23import Development.IDE.GHC.Warnings
24import Development.IDE.GHC.CPP
25import Development.IDE.Types.Diagnostics
26import qualified Development.IDE.Import.FindImports as FindImports
27import Development.IDE.GHC.Error
28import Development.IDE.Spans.Calculate
29import Development.IDE.GHC.Util
30import Development.IDE.GHC.Compat
31import Development.IDE.Types.Options
32import Development.IDE.Types.Location
34import GHC hiding (parseModule, typecheckModule)
35import qualified Parser
36import Lexer
37import ErrUtils
39import qualified GHC
40import Panic
41import GhcMonad
42import GhcPlugins as GHC hiding (fst3, (<>))
43import qualified HeaderInfo as Hdr
44import MkIface
45import NameCache
46import StringBuffer as SB
47import TidyPgm
48import qualified GHC.LanguageExtensions as LangExt
50import Control.DeepSeq
51import Control.Exception as E
52import Control.Monad
53import qualified Control.Monad.Trans.Except as Ex
54import Data.IORef
55import Data.List.Extra
56import Data.Maybe
57import Data.Tuple.Extra
58import qualified Data.Map.Strict as Map
59import Development.IDE.Spans.Type
60import GHC.Generics (Generic)
61import System.FilePath
62import System.Directory
63import System.IO.Extra
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 -> HscEnv
96 -> [(Located ModuleName, Maybe NormalizedFilePath)]
97 -> TcModuleResult
98 -> IO [SpanInfo]
99getSrcSpanInfos opt mod env imports tc =
100 runGhcSession opt (Just mod) env
101 . getSpanInfo imports
102 $ tmrModule tc
105-- | Given a string buffer, return a pre-processed @ParsedModule@.
106parseModule
107 :: IdeOptions
108 -> HscEnv
109 -> FilePath
110 -> 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 -> HscEnv -> 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 -> HscEnv
138 -> [TcModuleResult]
139 -> ParsedModule
140 -> IO ([FileDiagnostic], Maybe TcModuleResult)
141typecheckModule opt packageState deps pm =
142 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
143 runGhcSessionExcept opt (Just pm) packageState $
144 catchSrcErrors $ do
145 setupEnv deps
146 (warnings, tcm) <- withWarnings $ \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 -> HscEnv
155 -> InstalledUnitId
156 -> IO (Either [FileDiagnostic] LoadPackageResult)
157loadPackage opt packageState p =
158 Ex.runExceptT $
159 runGhcSessionExcept opt Nothing packageState $
160 catchSrcErrors $ do
161 setupEnv []
162 -- this populates the namecache and external package state
163 session <- getSession
164 modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
165 eps <- liftIO (readIORef $ hsc_EPS session)
166 pure $ LoadPackageResult p modEnv eps
168-- | Compile a single type-checked module to a 'CoreModule' value, or
169-- provide errors.
170compileModule
171 :: IdeOptions
172 -> ParsedModule
173 -> HscEnv
174 -> [TcModuleResult]
175 -> TcModuleResult
176 -> IO ([FileDiagnostic], Maybe GhcModule)
177compileModule opt mod packageState deps tmr =
178 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
179 runGhcSessionExcept opt (Just mod) packageState $
180 catchSrcErrors $ do
181 setupEnv (deps ++ [tmr])
183 let tm = tmrModule tmr
184 session <- getSession
185 (warnings,desugar) <- withWarnings $ \tweak -> do
186 let pm = tm_parsed_module tm
187 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
188 let tm' = tm{tm_parsed_module = pm'}
189 GHC.dm_core_module <$> GHC.desugarModule tm'
191 -- give variables unique OccNames
192 (tidy, details) <- liftIO $ tidyProgram session desugar
194 let path = ml_hs_file $ ms_location $ pm_mod_summary $ tm_parsed_module tm
195 let core = CoreModule
196 (cg_module tidy)
197 (md_types details)
198 (cg_binds tidy)
199 (mg_safe_haskell desugar)
201 return (warnings, GhcModule path core)
203-- | Evaluate a GHC session using a new environment constructed with
204-- the supplied options.
205runGhcSessionExcept
206 :: IdeOptions
207 -> Maybe ParsedModule
208 -> HscEnv
209 -> Ex.ExceptT e Ghc a
210 -> Ex.ExceptT e IO a
211runGhcSessionExcept opts mbMod pkg m =
212 Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
215getGhcDynFlags :: IdeOptions -> ParsedModule -> HscEnv -> IO DynFlags
216getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
218-- | Evaluate a GHC session using a new environment constructed with
219-- the supplied options.
220runGhcSession
221 :: IdeOptions
222 -> Maybe ParsedModule
223 -> HscEnv
224 -> Ghc a
225 -> IO a
226runGhcSession IdeOptions{..} modu env act = runGhcEnv env $ do
227 modifyDynFlags $ \x -> x
228 {importPaths = nubOrd $ maybeToList (moduleImportPaths =<< modu) ++ importPaths x}
229 act
232moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
233moduleImportPaths pm
234 | rootModDir == "." = Just rootPathDir
235 | otherwise =
236 -- TODO (MK) stripSuffix (normalise rootModDir) (normalise rootPathDir)
237 -- would be a better choice but at the moment we do not consistently
238 -- normalize file paths in the Shake graph so we can end up with the
239 -- same module being represented twice in the Shake graph.
240 Just $ dropTrailingPathSeparator $ dropEnd (length rootModDir) rootPathDir
241 where
242 ms = GHC.pm_mod_summary pm
243 file = GHC.ms_hspp_file ms
244 mod' = GHC.ms_mod ms
245 rootPathDir = takeDirectory file
246 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
249newtype WriteInterface = WriteInterface Bool
251mkTcModuleResult
252 :: GhcMonad m
253 => WriteInterface
254 -> TypecheckedModule
255 -> m TcModuleResult
256mkTcModuleResult (WriteInterface writeIface) tcm = do
257 session <- getSession
258 nc <- liftIO $ readIORef (hsc_NC session)
259 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
260 liftIO $ when writeIface $ do
261 let path = ".interfaces" </> file tcm
262 createDirectoryIfMissing True (takeDirectory path)
263 writeIfaceFile (hsc_dflags session) (replaceExtension path ".hi") iface
264 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
265 -- when we are building a package. It should be easily decoupable if that turns out to be
266 -- useful.
267 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
268 writeHieFile (replaceExtension path ".hie") hieFile
269 let mod_info = HomeModInfo iface details Nothing
270 origNc = nsNames nc
271 case lookupModuleEnv origNc (tcmModule tcm) of
272 Nothing -> panic err
273 Just occ -> return $ TcModuleResult tcm mod_info occ
274 where
275 file = ms_hspp_file . tcModSummary
276 tcmModule = ms_mod . tcModSummary
277 (tcGblEnv, details) = tm_internals_ tcm
278 err = "Internal error : module not found in NameCache :" <>
279 moduleNameString (moduleName $ tcmModule tcm)
281tcModSummary :: TypecheckedModule -> ModSummary
282tcModSummary = pm_mod_summary . tm_parsed_module
284-- | Setup the environment that GHC needs according to our
285-- best understanding (!)
286setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
287setupEnv tms = do
288 session <- getSession
290 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
292 -- set the target and module graph in the session
293 let graph = mkModuleGraph mss
294 setSession session { hsc_mod_graph = graph }
296 -- Make modules available for others that import them,
297 -- by putting them in the finder cache.
298 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
299 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
300 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
301 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
302 $ zip ims ifrs
304 -- load dependent modules, which must be in topological order.
305 mapM_ loadModuleHome tms
308-- | Load a module, quickly. Input doesn't need to be desugared.
309-- A module must be loaded before dependent modules can be typechecked.
310-- This variant of loadModuleHome will *never* cause recompilation, it just
311-- modifies the session.
312loadModuleHome
313 :: (GhcMonad m)
314 => TcModuleResult
315 -> m ()
316loadModuleHome tmr = modifySession $ \e ->
317 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
318 where
319 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
320 mod_info = tmrModInfo tmr
321 mod = ms_mod_name ms
323-- | Produce a module summary from a StringBuffer.
324getModSummaryFromBuffer
325 :: GhcMonad m
326 => FilePath
327 -> SB.StringBuffer
328 -> DynFlags
329 -> GHC.ParsedSource
330 -> Ex.ExceptT [FileDiagnostic] m ModSummary
331getModSummaryFromBuffer fp contents dflags parsed = do
332 (modName, imports) <- FindImports.getImportsParsed dflags parsed
334 let modLoc = ModLocation
335 { ml_hs_file = Just fp
336 , ml_hi_file = replaceExtension fp "hi"
337 , ml_obj_file = replaceExtension fp "o"
338#ifndef GHC_STABLE
339 , ml_hie_file = replaceExtension fp "hie"
340#endif
341 -- This does not consider the dflags configuration
342 -- (-osuf and -hisuf, object and hi dir.s).
343 -- However, we anyway don't want to generate them.
344 }
345 InstalledUnitId unitId = thisInstalledUnitId dflags
346 return $ ModSummary
347 { ms_mod = mkModule (fsToUnitId unitId) modName
348 , ms_location = modLoc
349 , ms_hs_date = error "Rules should not depend on ms_hs_date"
350 -- ^ When we are working with a virtual file we do not have a file date.
351 -- To avoid silent issues where something is not processed because the date
352 -- has not changed, we make sure that things blow up if they depend on the
353 -- date.
354 , ms_textual_imps = imports
355 , ms_hspp_file = fp
356 , ms_hspp_opts = dflags
357 , ms_hspp_buf = Just contents
359 -- defaults:
360 , ms_hsc_src = HsSrcFile
361 , ms_obj_date = Nothing
362 , ms_iface_date = Nothing
363#ifndef GHC_STABLE
364 , ms_hie_date = Nothing
365#endif
366 , ms_srcimps = [] -- source imports are not allowed
367 , ms_parsed_mod = Nothing
368 }
370-- | Given a buffer, flags, file path and module summary, produce a
371-- parsed module (or errors) and any parse warnings.
372parseFileContents
373 :: GhcMonad m
374 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
375 -> FilePath -- ^ the filename (for source locations)
376 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
377 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
378parseFileContents preprocessor filename contents = do
379 let loc = mkRealSrcLoc (mkFastString filename) 1 1
380 dflags <- parsePragmasIntoDynFlags filename contents
382 (contents, dflags) <-
383 if not $ xopt LangExt.Cpp dflags then
384 return (contents, dflags)
385 else do
386 contents <- liftIO $ withTempDir $ \dir -> do
387 let inp = dir </> takeFileName filename
388 let out = dir </> takeFileName filename <.> "out"
389 let f x = if SB.atEnd x then Nothing else Just $ SB.nextChar x
390 liftIO $ writeFileUTF8 inp (unfoldr f contents)
391 doCpp dflags True inp out
392 liftIO $ SB.hGetStringBuffer out
393 dflags <- parsePragmasIntoDynFlags filename contents
394 return (contents, dflags)
396 case unP Parser.parseModule (mkPState dflags contents loc) of
397 PFailed _ locErr msgErr ->
398 Ex.throwE $ diagFromErrMsg dflags $ mkPlainErrMsg dflags locErr msgErr
399 POk pst rdr_module ->
400 let hpm_annotations =
401 (Map.fromListWith (++) $ annotations pst,
402 Map.fromList ((noSrcSpan,comment_q pst)
403 :annotations_comments pst))
404 (warns, errs) = getMessages pst dflags
405 in
406 do
407 -- Just because we got a `POk`, it doesn't mean there
408 -- weren't errors! To clarify, the GHC parser
409 -- distinguishes between fatal and non-fatal
410 -- errors. Non-fatal errors are the sort that don't
411 -- prevent parsing from continuing (that is, a parse
412 -- tree can still be produced despite the error so that
413 -- further errors/warnings can be collected). Fatal
414 -- errors are those from which a parse tree just can't
415 -- be produced.
416 unless (null errs) $
417 Ex.throwE $ diagFromErrMsgs dflags $ snd $ getMessages pst dflags
419 -- Ok, we got here. It's safe to continue.
420 let (errs, parsed) = preprocessor rdr_module
421 unless (null errs) $ Ex.throwE $ diagFromStrings errs
422 ms <- getModSummaryFromBuffer filename contents dflags parsed
423 let pm =
424 ParsedModule {
425 pm_mod_summary = ms
426 , pm_parsed_source = parsed
427 , pm_extra_src_files=[] -- src imports not allowed
428 , pm_annotations = hpm_annotations
429 }
430 warnings = diagFromErrMsgs dflags warns
431 pure (warnings, pm)
434-- | This reads the pragma information directly from the provided buffer.
435parsePragmasIntoDynFlags
436 :: GhcMonad m
437 => FilePath
438 -> SB.StringBuffer
439 -> Ex.ExceptT [FileDiagnostic] m DynFlags
440parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
441 dflags0 <- getSessionDynFlags
442 let opts = Hdr.getOptions dflags0 contents fp
443 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
444 return dflags
446-- | Run something in a Ghc monad and catch the errors (SourceErrors and
447-- compiler-internal exceptions like Panic or InstallationError).
448catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [FileDiagnostic] m a
449catchSrcErrors ghcM = do
450 dflags <- getDynFlags
451 Ex.ExceptT $
452 handleGhcException (ghcExceptionToDiagnostics dflags) $
453 handleSourceError (sourceErrorToDiagnostics dflags) $
454 Right <$> ghcM
455 where
456 ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException dflags
457 sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs dflags . srcErrorMessages