git.iko.soy/ghcide
on 210de4e help sign in
ghcide/src/Development/IDE/Functions/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.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 -> ParsedModule
137 -> HscEnv
138 -> [TcModuleResult]
139 -> ParsedModule
140 -> IO ([FileDiagnostic], Maybe TcModuleResult)
141typecheckModule opt mod packageState deps pm =
142 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
143 runGhcSessionExcept opt (Just mod) packageState $
144 catchSrcErrors $ do
145 setupEnv deps
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 -> 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 "Desugarer" $ \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 $ mkErrorDoc 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 $ toDiagnostics 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 $ mkErrors dflags 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 = mapMaybe (mkDiag dflags "Parser") $ bagToList 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 . mkErrorsGhcException dflags
457 sourceErrorToDiagnostics dflags = return . Left . toDiagnostics dflags . srcErrorMessages