git.iko.soy/ghcide
on e370589 help sign in
ghcide/src/Development/IDE/Functions/Compile.hs
460 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 Data.Time
59import Development.IDE.Types.SpanInfo
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 FilePath)]
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 -> (UTCTime, 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 -> ParsedModule
138 -> HscEnv
139 -> [TcModuleResult]
140 -> ParsedModule
141 -> IO ([FileDiagnostic], Maybe TcModuleResult)
142typecheckModule opt mod packageState deps pm =
143 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
144 runGhcSessionExcept opt (Just mod) packageState $
145 catchSrcErrors $ do
146 setupEnv deps
147 (warnings, tcm) <- withWarnings "Typechecker" $ \tweak ->
148 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
149 tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
150 return (warnings, tcm2)
152-- | Load a pkg and populate the name cache and external package state.
153loadPackage ::
154 IdeOptions
155 -> HscEnv
156 -> InstalledUnitId
157 -> IO (Either [FileDiagnostic] LoadPackageResult)
158loadPackage opt packageState p =
159 Ex.runExceptT $
160 runGhcSessionExcept opt Nothing packageState $
161 catchSrcErrors $ do
162 setupEnv []
163 -- this populates the namecache and external package state
164 session <- getSession
165 modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
166 eps <- liftIO (readIORef $ hsc_EPS session)
167 pure $ LoadPackageResult p modEnv eps
169-- | Compile a single type-checked module to a 'CoreModule' value, or
170-- provide errors.
171compileModule
172 :: IdeOptions
173 -> ParsedModule
174 -> HscEnv
175 -> [TcModuleResult]
176 -> TcModuleResult
177 -> IO ([FileDiagnostic], Maybe GhcModule)
178compileModule opt mod packageState deps tmr =
179 fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
180 runGhcSessionExcept opt (Just mod) packageState $
181 catchSrcErrors $ do
182 setupEnv (deps ++ [tmr])
184 let tm = tmrModule tmr
185 session <- getSession
186 (warnings,desugar) <- withWarnings "Desugarer" $ \tweak -> do
187 let pm = tm_parsed_module tm
188 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
189 let tm' = tm{tm_parsed_module = pm'}
190 GHC.dm_core_module <$> GHC.desugarModule tm'
192 -- give variables unique OccNames
193 (tidy, details) <- liftIO $ tidyProgram session desugar
195 let path = ml_hs_file $ ms_location $ pm_mod_summary $ tm_parsed_module tm
196 let core = CoreModule
197 (cg_module tidy)
198 (md_types details)
199 (cg_binds tidy)
200 (mg_safe_haskell desugar)
202 return (warnings, GhcModule path core)
204-- | Evaluate a GHC session using a new environment constructed with
205-- the supplied options.
206runGhcSessionExcept
207 :: IdeOptions
208 -> Maybe ParsedModule
209 -> HscEnv
210 -> Ex.ExceptT e Ghc a
211 -> Ex.ExceptT e IO a
212runGhcSessionExcept opts mbMod pkg m =
213 Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
216getGhcDynFlags :: IdeOptions -> ParsedModule -> HscEnv -> IO DynFlags
217getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
219-- | Evaluate a GHC session using a new environment constructed with
220-- the supplied options.
221runGhcSession
222 :: IdeOptions
223 -> Maybe ParsedModule
224 -> HscEnv
225 -> Ghc a
226 -> IO a
227runGhcSession IdeOptions{..} modu env act = runGhcEnv env $ do
228 modifyDynFlags $ \x -> x
229 {importPaths = nubOrd $ maybeToList (moduleImportPaths =<< modu) ++ importPaths x}
230 act
233moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
234moduleImportPaths pm
235 | rootModDir == "." = Just rootPathDir
236 | otherwise =
237 -- TODO (MK) stripSuffix (normalise rootModDir) (normalise rootPathDir)
238 -- would be a better choice but at the moment we do not consistently
239 -- normalize file paths in the Shake graph so we can end up with the
240 -- same module being represented twice in the Shake graph.
241 Just $ dropTrailingPathSeparator $ dropEnd (length rootModDir) rootPathDir
242 where
243 ms = GHC.pm_mod_summary pm
244 file = GHC.ms_hspp_file ms
245 mod' = GHC.ms_mod ms
246 rootPathDir = takeDirectory file
247 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
250newtype WriteInterface = WriteInterface Bool
252mkTcModuleResult
253 :: GhcMonad m
254 => WriteInterface
255 -> TypecheckedModule
256 -> m TcModuleResult
257mkTcModuleResult (WriteInterface writeIface) tcm = do
258 session <- getSession
259 nc <- liftIO $ readIORef (hsc_NC session)
260 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
261 liftIO $ when writeIface $ do
262 let path = ".interfaces" </> file tcm
263 createDirectoryIfMissing True (takeDirectory path)
264 writeIfaceFile (hsc_dflags session) (replaceExtension path ".hi") iface
265 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
266 -- when we are building a package. It should be easily decoupable if that turns out to be
267 -- useful.
268 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
269 writeHieFile (replaceExtension path ".hie") hieFile
270 let mod_info = HomeModInfo iface details Nothing
271 origNc = nsNames nc
272 case lookupModuleEnv origNc (tcmModule tcm) of
273 Nothing -> panic err
274 Just occ -> return $ TcModuleResult tcm mod_info occ
275 where
276 file = ms_hspp_file . tcModSummary
277 tcmModule = ms_mod . tcModSummary
278 (tcGblEnv, details) = tm_internals_ tcm
279 err = "Internal error : module not found in NameCache :" <>
280 moduleNameString (moduleName $ tcmModule tcm)
282tcModSummary :: TypecheckedModule -> ModSummary
283tcModSummary = pm_mod_summary . tm_parsed_module
285-- | Setup the environment that GHC needs according to our
286-- best understanding (!)
287setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
288setupEnv tms = do
289 session <- getSession
291 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
293 -- set the target and module graph in the session
294 let graph = mkModuleGraph mss
295 setSession session { hsc_mod_graph = graph }
297 -- Make modules available for others that import them,
298 -- by putting them in the finder cache.
299 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
300 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
301 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
302 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
303 $ zip ims ifrs
305 -- load dependent modules, which must be in topological order.
306 mapM_ loadModuleHome tms
309-- | Load a module, quickly. Input doesn't need to be desugared.
310-- A module must be loaded before dependent modules can be typechecked.
311-- This variant of loadModuleHome will *never* cause recompilation, it just
312-- modifies the session.
313loadModuleHome
314 :: (GhcMonad m)
315 => TcModuleResult
316 -> m ()
317loadModuleHome tmr = modifySession $ \e ->
318 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
319 where
320 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
321 mod_info = tmrModInfo tmr
322 mod = ms_mod_name ms
324-- | Produce a module summary from a StringBuffer.
325getModSummaryFromBuffer
326 :: GhcMonad m
327 => FilePath
328 -> (SB.StringBuffer, UTCTime)
329 -> DynFlags
330 -> GHC.ParsedSource
331 -> Ex.ExceptT [FileDiagnostic] m ModSummary
332getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do
333 (modName, imports) <- FindImports.getImportsParsed dflags parsed
335 let modLoc = ModLocation
336 { ml_hs_file = Just fp
337 , ml_hi_file = replaceExtension fp "hi"
338 , ml_obj_file = replaceExtension fp "o"
339#ifndef GHC_STABLE
340 , ml_hie_file = replaceExtension fp "hie"
341#endif
342 -- This does not consider the dflags configuration
343 -- (-osuf and -hisuf, object and hi dir.s).
344 -- However, we anyway don't want to generate them.
345 }
346 InstalledUnitId unitId = thisInstalledUnitId dflags
347 return $ ModSummary
348 { ms_mod = mkModule (fsToUnitId unitId) modName
349 , ms_location = modLoc
350 , ms_hs_date = fileDate
351 , ms_textual_imps = imports
352 , ms_hspp_file = fp
353 , ms_hspp_opts = dflags
354 , ms_hspp_buf = Just contents
356 -- defaults:
357 , ms_hsc_src = HsSrcFile
358 , ms_obj_date = Nothing
359 , ms_iface_date = Nothing
360#ifndef GHC_STABLE
361 , ms_hie_date = Nothing
362#endif
363 , ms_srcimps = [] -- source imports are not allowed
364 , ms_parsed_mod = Nothing
365 }
367-- | Given a buffer, flags, file path and module summary, produce a
368-- parsed module (or errors) and any parse warnings.
369parseFileContents
370 :: GhcMonad m
371 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
372 -> FilePath -- ^ the filename (for source locations)
373 -> (UTCTime, SB.StringBuffer) -- ^ Haskell module source text (full Unicode is supported)
374 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
375parseFileContents preprocessor filename (time, contents) = do
376 let loc = mkRealSrcLoc (mkFastString filename) 1 1
377 dflags <- parsePragmasIntoDynFlags filename contents
379 (contents, dflags) <-
380 if not $ xopt LangExt.Cpp dflags then
381 return (contents, dflags)
382 else do
383 contents <- liftIO $ withTempDir $ \dir -> do
384 let inp = dir </> takeFileName filename
385 let out = dir </> takeFileName filename <.> "out"
386 let f x = if SB.atEnd x then Nothing else Just $ SB.nextChar x
387 liftIO $ writeFileUTF8 inp (unfoldr f contents)
388 doCpp dflags True inp out
389 liftIO $ SB.hGetStringBuffer out
390 dflags <- parsePragmasIntoDynFlags filename contents
391 return (contents, dflags)
393 case unP Parser.parseModule (mkPState dflags contents loc) of
394#ifdef GHC_STABLE
395 PFailed _ locErr msgErr ->
396 Ex.throwE $ mkErrorDoc dflags locErr msgErr
397#else
398 PFailed s ->
399 -- A fatal parse error was encountered.
400 Ex.throwE $ toDiagnostics dflags $ snd $ getMessages s dflags
401#endif
402 POk pst rdr_module ->
403 let hpm_annotations =
404 (Map.fromListWith (++) $ annotations pst,
405 Map.fromList ((noSrcSpan,comment_q pst)
406 :annotations_comments pst))
407 (warns, errs) = getMessages pst dflags
408 in
409 do
410 -- Just because we got a `POk`, it doesn't mean there
411 -- weren't errors! To clarify, the GHC parser
412 -- distinguishes between fatal and non-fatal
413 -- errors. Non-fatal errors are the sort that don't
414 -- prevent parsing from continuing (that is, a parse
415 -- tree can still be produced despite the error so that
416 -- further errors/warnings can be collected). Fatal
417 -- errors are those from which a parse tree just can't
418 -- be produced.
419 unless (null errs) $
420 Ex.throwE $ toDiagnostics dflags $ snd $ getMessages pst dflags
422 -- Ok, we got here. It's safe to continue.
423 let (errs, parsed) = preprocessor rdr_module
424 unless (null errs) $ Ex.throwE $ mkErrors dflags errs
425 ms <- getModSummaryFromBuffer filename (contents, time) dflags parsed
426 let pm =
427 ParsedModule {
428 pm_mod_summary = ms
429 , pm_parsed_source = parsed
430 , pm_extra_src_files=[] -- src imports not allowed
431 , pm_annotations = hpm_annotations
432 }
433 warnings = mapMaybe (mkDiag dflags "Parser") $ bagToList warns
434 pure (warnings, pm)
437-- | This reads the pragma information directly from the provided buffer.
438parsePragmasIntoDynFlags
439 :: GhcMonad m
440 => FilePath
441 -> SB.StringBuffer
442 -> Ex.ExceptT [FileDiagnostic] m DynFlags
443parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
444 dflags0 <- getSessionDynFlags
445 let opts = Hdr.getOptions dflags0 contents fp
446 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
447 return dflags
449-- | Run something in a Ghc monad and catch the errors (SourceErrors and
450-- compiler-internal exceptions like Panic or InstallationError).
451catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [FileDiagnostic] m a
452catchSrcErrors ghcM = do
453 dflags <- getDynFlags
454 Ex.ExceptT $
455 handleGhcException (ghcExceptionToDiagnostics dflags) $
456 handleSourceError (sourceErrorToDiagnostics dflags) $
457 Right <$> ghcM
458 where
459 ghcExceptionToDiagnostics dflags = return . Left . mkErrorsGhcException dflags
460 sourceErrorToDiagnostics dflags = return . Left . toDiagnostics dflags . srcErrorMessages