git.iko.soy/ghcide
on cb7d95e help sign in
ghcide/src/Development/IDE/Functions/Compile.hs
456 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.Functions.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.Functions.Warnings
24import Development.IDE.Functions.CPP
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.Compat
31import Development.IDE.Types.Options
33import GHC hiding (parseModule, typecheckModule)
34import qualified Parser
35import Lexer
36import Bag
38import qualified GHC
39import Panic
40import GhcMonad
41import GhcPlugins as GHC hiding (fst3, (<>))
42import qualified HeaderInfo as Hdr
43import MkIface
44import NameCache
45import StringBuffer as SB
46import TidyPgm
47import qualified GHC.LanguageExtensions as LangExt
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 Development.IDE.Types.SpanInfo
59import GHC.Generics (Generic)
60import System.FilePath
61import System.Directory
62import System.IO.Extra
65-- | 'CoreModule' together with some additional information required for the
66-- conversion to DAML-LF.
67data GhcModule = GhcModule
68 { gmPath :: Maybe FilePath
69 , gmCore :: CoreModule
70 }
71 deriving (Generic, Show)
73instance NFData GhcModule
75-- | Contains the typechecked module and the OrigNameCache entry for
76-- that module.
77data TcModuleResult = TcModuleResult
78 { tmrModule :: TypecheckedModule
79 , tmrModInfo :: HomeModInfo
80 , tmrOccEnvName :: OccEnv Name
81 }
83-- | Contains the result of loading an interface. In particular the delta to the name cache.
84data LoadPackageResult = LoadPackageResult
85 { lprInstalledUnitId :: InstalledUnitId
86 , lprModuleEnv :: ModuleEnv (OccEnv Name)
87 , lprEps :: ExternalPackageState
88 }
90-- | Get source span info, used for e.g. AtPoint and Goto Definition.
91getSrcSpanInfos
92 :: IdeOptions
93 -> ParsedModule
94 -> HscEnv
95 -> [(Located ModuleName, Maybe NormalizedFilePath)]
96 -> TcModuleResult
97 -> IO [SpanInfo]
98getSrcSpanInfos opt mod env imports tc =
99 runGhcSession opt (Just mod) env
100 . getSpanInfo imports
101 $ tmrModule tc
104-- | Given a string buffer, return a pre-processed @ParsedModule@.
105parseModule
106 :: IdeOptions
107 -> HscEnv
108 -> FilePath
109 -> SB.StringBuffer
110 -> IO ([FileDiagnostic], Maybe ParsedModule)
111parseModule opt@IdeOptions{..} packageState file =
112 fmap (either (, Nothing) (second Just)) . Ex.runExceptT .
113 -- We need packages since imports fail to resolve otherwise.
114 runGhcSessionExcept opt Nothing packageState . parseFileContents optPreprocessor file
116computePackageDeps ::
117 IdeOptions -> HscEnv -> InstalledUnitId -> IO (Either [FileDiagnostic] [InstalledUnitId])
118computePackageDeps opts packageState iuid =
119 Ex.runExceptT $
120 runGhcSessionExcept opts Nothing packageState $
121 catchSrcErrors $ do
122 dflags <- hsc_dflags <$> getSession
123 liftIO $ depends <$> getPackage dflags iuid
125getPackage :: DynFlags -> InstalledUnitId -> IO PackageConfig
126getPackage dflags p =
127 case lookupInstalledPackage dflags p of
128 Nothing -> E.throwIO $ CmdLineError (missingPackageMsg p)
129 Just pkg -> return pkg
130 where
131 missingPackageMsg p = showSDoc dflags $ text "unknown package:" <+> ppr p
133-- | Typecheck a single module using the supplied dependencies and packages.
134typecheckModule
135 :: IdeOptions
136 -> HscEnv
137 -> [TcModuleResult]
138 -> ParsedModule
139 -> IO ([FileDiagnostic], Maybe TcModuleResult)
140typecheckModule opt packageState deps pm =
141 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
142 runGhcSessionExcept opt (Just pm) packageState $
143 catchSrcErrors $ do
144 setupEnv deps
145 (warnings, tcm) <- withWarnings "Typechecker" $ \tweak ->
146 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
147 tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
148 return (warnings, tcm2)
150-- | Load a pkg and populate the name cache and external package state.
151loadPackage ::
152 IdeOptions
153 -> HscEnv
154 -> InstalledUnitId
155 -> IO (Either [FileDiagnostic] LoadPackageResult)
156loadPackage opt packageState p =
157 Ex.runExceptT $
158 runGhcSessionExcept opt Nothing packageState $
159 catchSrcErrors $ do
160 setupEnv []
161 -- this populates the namecache and external package state
162 session <- getSession
163 modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
164 eps <- liftIO (readIORef $ hsc_EPS session)
165 pure $ LoadPackageResult p modEnv eps
167-- | Compile a single type-checked module to a 'CoreModule' value, or
168-- provide errors.
169compileModule
170 :: IdeOptions
171 -> ParsedModule
172 -> HscEnv
173 -> [TcModuleResult]
174 -> TcModuleResult
175 -> IO ([FileDiagnostic], Maybe GhcModule)
176compileModule opt mod packageState deps tmr =
177 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
178 runGhcSessionExcept opt (Just mod) packageState $
179 catchSrcErrors $ do
180 setupEnv (deps ++ [tmr])
182 let tm = tmrModule tmr
183 session <- getSession
184 (warnings,desugar) <- withWarnings "Desugarer" $ \tweak -> do
185 let pm = tm_parsed_module tm
186 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
187 let tm' = tm{tm_parsed_module = pm'}
188 GHC.dm_core_module <$> GHC.desugarModule tm'
190 -- give variables unique OccNames
191 (tidy, details) <- liftIO $ tidyProgram session desugar
193 let path = ml_hs_file $ ms_location $ pm_mod_summary $ tm_parsed_module tm
194 let core = CoreModule
195 (cg_module tidy)
196 (md_types details)
197 (cg_binds tidy)
198 (mg_safe_haskell desugar)
200 return (warnings, GhcModule path core)
202-- | Evaluate a GHC session using a new environment constructed with
203-- the supplied options.
204runGhcSessionExcept
205 :: IdeOptions
206 -> Maybe ParsedModule
207 -> HscEnv
208 -> Ex.ExceptT e Ghc a
209 -> Ex.ExceptT e IO a
210runGhcSessionExcept opts mbMod pkg m =
211 Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
214getGhcDynFlags :: IdeOptions -> ParsedModule -> HscEnv -> IO DynFlags
215getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
217-- | Evaluate a GHC session using a new environment constructed with
218-- the supplied options.
219runGhcSession
220 :: IdeOptions
221 -> Maybe ParsedModule
222 -> HscEnv
223 -> Ghc a
224 -> IO a
225runGhcSession IdeOptions{..} modu env act = runGhcEnv env $ do
226 modifyDynFlags $ \x -> x
227 {importPaths = nubOrd $ maybeToList (moduleImportPaths =<< modu) ++ importPaths x}
228 act
231moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
232moduleImportPaths pm
233 | rootModDir == "." = Just rootPathDir
234 | otherwise =
235 -- TODO (MK) stripSuffix (normalise rootModDir) (normalise rootPathDir)
236 -- would be a better choice but at the moment we do not consistently
237 -- normalize file paths in the Shake graph so we can end up with the
238 -- same module being represented twice in the Shake graph.
239 Just $ dropTrailingPathSeparator $ dropEnd (length rootModDir) rootPathDir
240 where
241 ms = GHC.pm_mod_summary pm
242 file = GHC.ms_hspp_file ms
243 mod' = GHC.ms_mod ms
244 rootPathDir = takeDirectory file
245 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
248newtype WriteInterface = WriteInterface Bool
250mkTcModuleResult
251 :: GhcMonad m
252 => WriteInterface
253 -> TypecheckedModule
254 -> m TcModuleResult
255mkTcModuleResult (WriteInterface writeIface) tcm = do
256 session <- getSession
257 nc <- liftIO $ readIORef (hsc_NC session)
258 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
259 liftIO $ when writeIface $ do
260 let path = ".interfaces" </> file tcm
261 createDirectoryIfMissing True (takeDirectory path)
262 writeIfaceFile (hsc_dflags session) (replaceExtension path ".hi") iface
263 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
264 -- when we are building a package. It should be easily decoupable if that turns out to be
265 -- useful.
266 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
267 writeHieFile (replaceExtension path ".hie") hieFile
268 let mod_info = HomeModInfo iface details Nothing
269 origNc = nsNames nc
270 case lookupModuleEnv origNc (tcmModule tcm) of
271 Nothing -> panic err
272 Just occ -> return $ TcModuleResult tcm mod_info occ
273 where
274 file = ms_hspp_file . tcModSummary
275 tcmModule = ms_mod . tcModSummary
276 (tcGblEnv, details) = tm_internals_ tcm
277 err = "Internal error : module not found in NameCache :" <>
278 moduleNameString (moduleName $ tcmModule tcm)
280tcModSummary :: TypecheckedModule -> ModSummary
281tcModSummary = pm_mod_summary . tm_parsed_module
283-- | Setup the environment that GHC needs according to our
284-- best understanding (!)
285setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
286setupEnv tms = do
287 session <- getSession
289 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
291 -- set the target and module graph in the session
292 let graph = mkModuleGraph mss
293 setSession session { hsc_mod_graph = graph }
295 -- Make modules available for others that import them,
296 -- by putting them in the finder cache.
297 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
298 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
299 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
300 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
301 $ zip ims ifrs
303 -- load dependent modules, which must be in topological order.
304 mapM_ loadModuleHome tms
307-- | Load a module, quickly. Input doesn't need to be desugared.
308-- A module must be loaded before dependent modules can be typechecked.
309-- This variant of loadModuleHome will *never* cause recompilation, it just
310-- modifies the session.
311loadModuleHome
312 :: (GhcMonad m)
313 => TcModuleResult
314 -> m ()
315loadModuleHome tmr = modifySession $ \e ->
316 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
317 where
318 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
319 mod_info = tmrModInfo tmr
320 mod = ms_mod_name ms
322-- | Produce a module summary from a StringBuffer.
323getModSummaryFromBuffer
324 :: GhcMonad m
325 => FilePath
326 -> SB.StringBuffer
327 -> DynFlags
328 -> GHC.ParsedSource
329 -> Ex.ExceptT [FileDiagnostic] m ModSummary
330getModSummaryFromBuffer fp contents dflags parsed = do
331 (modName, imports) <- FindImports.getImportsParsed dflags parsed
333 let modLoc = ModLocation
334 { ml_hs_file = Just fp
335 , ml_hi_file = replaceExtension fp "hi"
336 , ml_obj_file = replaceExtension fp "o"
337#ifndef GHC_STABLE
338 , ml_hie_file = replaceExtension fp "hie"
339#endif
340 -- This does not consider the dflags configuration
341 -- (-osuf and -hisuf, object and hi dir.s).
342 -- However, we anyway don't want to generate them.
343 }
344 InstalledUnitId unitId = thisInstalledUnitId dflags
345 return $ ModSummary
346 { ms_mod = mkModule (fsToUnitId unitId) modName
347 , ms_location = modLoc
348 , ms_hs_date = error "Rules should not depend on ms_hs_date"
349 -- ^ When we are working with a virtual file we do not have a file date.
350 -- To avoid silent issues where something is not processed because the date
351 -- has not changed, we make sure that things blow up if they depend on the
352 -- date.
353 , ms_textual_imps = imports
354 , ms_hspp_file = fp
355 , ms_hspp_opts = dflags
356 , ms_hspp_buf = Just contents
358 -- defaults:
359 , ms_hsc_src = HsSrcFile
360 , ms_obj_date = Nothing
361 , ms_iface_date = Nothing
362#ifndef GHC_STABLE
363 , ms_hie_date = Nothing
364#endif
365 , ms_srcimps = [] -- source imports are not allowed
366 , ms_parsed_mod = Nothing
367 }
369-- | Given a buffer, flags, file path and module summary, produce a
370-- parsed module (or errors) and any parse warnings.
371parseFileContents
372 :: GhcMonad m
373 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
374 -> FilePath -- ^ the filename (for source locations)
375 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
376 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
377parseFileContents preprocessor filename contents = do
378 let loc = mkRealSrcLoc (mkFastString filename) 1 1
379 dflags <- parsePragmasIntoDynFlags filename contents
381 (contents, dflags) <-
382 if not $ xopt LangExt.Cpp dflags then
383 return (contents, dflags)
384 else do
385 contents <- liftIO $ withTempDir $ \dir -> do
386 let inp = dir </> takeFileName filename
387 let out = dir </> takeFileName filename <.> "out"
388 let f x = if SB.atEnd x then Nothing else Just $ SB.nextChar x
389 liftIO $ writeFileUTF8 inp (unfoldr f contents)
390 doCpp dflags True inp out
391 liftIO $ SB.hGetStringBuffer out
392 dflags <- parsePragmasIntoDynFlags filename contents
393 return (contents, dflags)
395 case unP Parser.parseModule (mkPState dflags contents loc) of
396 PFailed _ locErr msgErr ->
397 Ex.throwE $ mkErrorDoc dflags locErr msgErr
398 POk pst rdr_module ->
399 let hpm_annotations =
400 (Map.fromListWith (++) $ annotations pst,
401 Map.fromList ((noSrcSpan,comment_q pst)
402 :annotations_comments pst))
403 (warns, errs) = getMessages pst dflags
404 in
405 do
406 -- Just because we got a `POk`, it doesn't mean there
407 -- weren't errors! To clarify, the GHC parser
408 -- distinguishes between fatal and non-fatal
409 -- errors. Non-fatal errors are the sort that don't
410 -- prevent parsing from continuing (that is, a parse
411 -- tree can still be produced despite the error so that
412 -- further errors/warnings can be collected). Fatal
413 -- errors are those from which a parse tree just can't
414 -- be produced.
415 unless (null errs) $
416 Ex.throwE $ toDiagnostics dflags $ snd $ getMessages pst dflags
418 -- Ok, we got here. It's safe to continue.
419 let (errs, parsed) = preprocessor rdr_module
420 unless (null errs) $ Ex.throwE $ mkErrors dflags errs
421 ms <- getModSummaryFromBuffer filename contents dflags parsed
422 let pm =
423 ParsedModule {
424 pm_mod_summary = ms
425 , pm_parsed_source = parsed
426 , pm_extra_src_files=[] -- src imports not allowed
427 , pm_annotations = hpm_annotations
428 }
429 warnings = mapMaybe (mkDiag dflags "Parser") $ bagToList warns
430 pure (warnings, pm)
433-- | This reads the pragma information directly from the provided buffer.
434parsePragmasIntoDynFlags
435 :: GhcMonad m
436 => FilePath
437 -> SB.StringBuffer
438 -> Ex.ExceptT [FileDiagnostic] m DynFlags
439parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
440 dflags0 <- getSessionDynFlags
441 let opts = Hdr.getOptions dflags0 contents fp
442 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
443 return dflags
445-- | Run something in a Ghc monad and catch the errors (SourceErrors and
446-- compiler-internal exceptions like Panic or InstallationError).
447catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [FileDiagnostic] m a
448catchSrcErrors ghcM = do
449 dflags <- getDynFlags
450 Ex.ExceptT $
451 handleGhcException (ghcExceptionToDiagnostics dflags) $
452 handleSourceError (sourceErrorToDiagnostics dflags) $
453 Right <$> ghcM
454 where
455 ghcExceptionToDiagnostics dflags = return . Left . mkErrorsGhcException dflags
456 sourceErrorToDiagnostics dflags = return . Left . toDiagnostics dflags . srcErrorMessages