git.iko.soy/ghcide
on eddf78a help sign in
ghcide/src/Development/IDE/Core/Compile.hs
434 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 ( TcModuleResult(..)
12 , getGhcDynFlags
13 , compileModule
14 , getSrcSpanInfos
15 , parseModule
16 , parseFileContents
17 , typecheckModule
18 , computePackageDeps
19 ) where
21import Development.IDE.GHC.Warnings
22import Development.IDE.GHC.CPP
23import Development.IDE.Types.Diagnostics
24import qualified Development.IDE.Import.FindImports as FindImports
25import Development.IDE.GHC.Error
26import Development.IDE.Spans.Calculate
27import Development.IDE.GHC.Orphans()
28import Development.IDE.GHC.Util
29import Development.IDE.GHC.Compat
30import Development.IDE.Types.Options
31import Development.IDE.Types.Location
33import GHC hiding (parseModule, typecheckModule)
34import qualified Parser
35import Lexer
36import ErrUtils
38import qualified GHC
39import Panic
40import GhcMonad
41import GhcPlugins as GHC hiding (fst3, (<>))
42import qualified HeaderInfo as Hdr
43import MkIface
44import StringBuffer as SB
45import TidyPgm
46import qualified GHC.LanguageExtensions as LangExt
48import Control.DeepSeq
49import Control.Monad
50import Control.Monad.Trans.Except
51import qualified Data.Text as T
52import Data.IORef
53import Data.List.Extra
54import Data.Maybe
55import Data.Tuple.Extra
56import qualified Data.Map.Strict as Map
57import Development.IDE.Spans.Type
58import System.FilePath
59import System.Directory
60import System.IO.Extra
61import Data.Char
64-- | Contains the typechecked module and the OrigNameCache entry for
65-- that module.
66data TcModuleResult = TcModuleResult
67 { tmrModule :: TypecheckedModule
68 , tmrModInfo :: HomeModInfo
69 }
70instance Show TcModuleResult where
71 show = show . pm_mod_summary . tm_parsed_module . tmrModule
73instance NFData TcModuleResult where
74 rnf = rwhnf
77-- | Get source span info, used for e.g. AtPoint and Goto Definition.
78getSrcSpanInfos
79 :: ParsedModule
80 -> HscEnv
81 -> [(Located ModuleName, Maybe NormalizedFilePath)]
82 -> TcModuleResult
83 -> IO [SpanInfo]
84getSrcSpanInfos mod env imports tc =
85 runGhcSession (Just mod) env
86 . getSpanInfo imports
87 $ tmrModule tc
90-- | Given a string buffer, return a pre-processed @ParsedModule@.
91parseModule
92 :: IdeOptions
93 -> HscEnv
94 -> FilePath
95 -> Maybe SB.StringBuffer
96 -> IO ([FileDiagnostic], Maybe ParsedModule)
97parseModule IdeOptions{..} env file =
98 fmap (either (, Nothing) (second Just)) .
99 -- We need packages since imports fail to resolve otherwise.
100 runGhcSession Nothing env . runExceptT . parseFileContents optPreprocessor file
103-- | Given a package identifier, what packages does it depend on
104computePackageDeps
105 :: HscEnv
106 -> InstalledUnitId
107 -> IO (Either [FileDiagnostic] [InstalledUnitId])
108computePackageDeps env pkg = do
109 let dflags = hsc_dflags env
110 case lookupInstalledPackage dflags pkg of
111 Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
112 T.pack $ "unknown package: " ++ show pkg]
113 Just pkgInfo -> return $ Right $ depends pkgInfo
116-- | Typecheck a single module using the supplied dependencies and packages.
117typecheckModule
118 :: IdeOptions
119 -> HscEnv
120 -> [TcModuleResult]
121 -> ParsedModule
122 -> IO ([FileDiagnostic], Maybe TcModuleResult)
123typecheckModule opt packageState deps pm =
124 fmap (either (, Nothing) (second Just)) $
125 runGhcSession (Just pm) packageState $
126 catchSrcErrors $ do
127 setupEnv deps
128 (warnings, tcm) <- withWarnings $ \tweak ->
129 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
130 tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
131 return (warnings, tcm2)
133-- | Compile a single type-checked module to a 'CoreModule' value, or
134-- provide errors.
135compileModule
136 :: ParsedModule
137 -> HscEnv
138 -> [TcModuleResult]
139 -> TcModuleResult
140 -> IO ([FileDiagnostic], Maybe CoreModule)
141compileModule mod packageState deps tmr =
142 fmap (either (, Nothing) (second Just)) $
143 runGhcSession (Just mod) packageState $
144 catchSrcErrors $ do
145 setupEnv (deps ++ [tmr])
147 let tm = tmrModule tmr
148 session <- getSession
149 (warnings,desugar) <- withWarnings $ \tweak -> do
150 let pm = tm_parsed_module tm
151 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
152 let tm' = tm{tm_parsed_module = pm'}
153 GHC.dm_core_module <$> GHC.desugarModule tm'
155 -- give variables unique OccNames
156 (tidy, details) <- liftIO $ tidyProgram session desugar
158 let core = CoreModule
159 (cg_module tidy)
160 (md_types details)
161 (cg_binds tidy)
162 (mg_safe_haskell desugar)
164 return (warnings, core)
167getGhcDynFlags :: ParsedModule -> HscEnv -> IO DynFlags
168getGhcDynFlags mod pkg = runGhcSession (Just mod) pkg getSessionDynFlags
170-- | Evaluate a GHC session using a new environment constructed with
171-- the supplied options.
172runGhcSession
173 :: Maybe ParsedModule
174 -> HscEnv
175 -> Ghc a
176 -> IO a
177runGhcSession modu env act = runGhcEnv env $ do
178 modifyDynFlags $ \x -> x
179 {importPaths = nubOrd $ maybeToList (moduleImportPaths =<< modu) ++ importPaths x}
180 act
183moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath
184moduleImportPaths pm
185 | rootModDir == "." = Just rootPathDir
186 | otherwise =
187 -- TODO (MK) stripSuffix (normalise rootModDir) (normalise rootPathDir)
188 -- would be a better choice but at the moment we do not consistently
189 -- normalize file paths in the Shake graph so we can end up with the
190 -- same module being represented twice in the Shake graph.
191 Just $ dropTrailingPathSeparator $ dropEnd (length rootModDir) rootPathDir
192 where
193 ms = GHC.pm_mod_summary pm
194 file = GHC.ms_hspp_file ms
195 mod' = GHC.ms_mod ms
196 rootPathDir = takeDirectory file
197 rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'
200newtype WriteInterface = WriteInterface Bool
202mkTcModuleResult
203 :: GhcMonad m
204 => WriteInterface
205 -> TypecheckedModule
206 -> m TcModuleResult
207mkTcModuleResult (WriteInterface writeIface) tcm = do
208 session <- getSession
209 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
210 liftIO $ when writeIface $ do
211 let path = ".interfaces" </> file tcm
212 createDirectoryIfMissing True (takeDirectory path)
213 writeIfaceFile (hsc_dflags session) (replaceExtension path ".hi") iface
214 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
215 -- when we are building a package. It should be easily decoupable if that turns out to be
216 -- useful.
217 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
218 writeHieFile (replaceExtension path ".hie") hieFile
219 let mod_info = HomeModInfo iface details Nothing
220 return $ TcModuleResult tcm mod_info
221 where
222 file = ms_hspp_file . tcModSummary
223 (tcGblEnv, details) = tm_internals_ tcm
225tcModSummary :: TypecheckedModule -> ModSummary
226tcModSummary = pm_mod_summary . tm_parsed_module
228-- | Setup the environment that GHC needs according to our
229-- best understanding (!)
230setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
231setupEnv tms = do
232 session <- getSession
234 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
236 -- set the target and module graph in the session
237 let graph = mkModuleGraph mss
238 setSession session { hsc_mod_graph = graph }
240 -- Make modules available for others that import them,
241 -- by putting them in the finder cache.
242 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
243 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
244 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
245 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
246 $ zip ims ifrs
248 -- load dependent modules, which must be in topological order.
249 mapM_ loadModuleHome tms
252-- | Load a module, quickly. Input doesn't need to be desugared.
253-- A module must be loaded before dependent modules can be typechecked.
254-- This variant of loadModuleHome will *never* cause recompilation, it just
255-- modifies the session.
256loadModuleHome
257 :: (GhcMonad m)
258 => TcModuleResult
259 -> m ()
260loadModuleHome tmr = modifySession $ \e ->
261 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
262 where
263 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
264 mod_info = tmrModInfo tmr
265 mod = ms_mod_name ms
267-- | Produce a module summary from a StringBuffer.
268getModSummaryFromBuffer
269 :: GhcMonad m
270 => FilePath
271 -> SB.StringBuffer
272 -> DynFlags
273 -> GHC.ParsedSource
274 -> ExceptT [FileDiagnostic] m ModSummary
275getModSummaryFromBuffer fp contents dflags parsed = do
276 (modName, imports) <- FindImports.getImportsParsed dflags parsed
278 let modLoc = ModLocation
279 { ml_hs_file = Just fp
280 , ml_hi_file = replaceExtension fp "hi"
281 , ml_obj_file = replaceExtension fp "o"
282#ifndef GHC_STABLE
283 , ml_hie_file = replaceExtension fp "hie"
284#endif
285 -- This does not consider the dflags configuration
286 -- (-osuf and -hisuf, object and hi dir.s).
287 -- However, we anyway don't want to generate them.
288 }
289 InstalledUnitId unitId = thisInstalledUnitId dflags
290 return $ ModSummary
291 { ms_mod = mkModule (fsToUnitId unitId) modName
292 , ms_location = modLoc
293 , ms_hs_date = error "Rules should not depend on ms_hs_date"
294 -- ^ When we are working with a virtual file we do not have a file date.
295 -- To avoid silent issues where something is not processed because the date
296 -- has not changed, we make sure that things blow up if they depend on the
297 -- date.
298 , ms_textual_imps = imports
299 , ms_hspp_file = fp
300 , ms_hspp_opts = dflags
301 , ms_hspp_buf = Just contents
303 -- defaults:
304 , ms_hsc_src = HsSrcFile
305 , ms_obj_date = Nothing
306 , ms_iface_date = Nothing
307#ifndef GHC_STABLE
308 , ms_hie_date = Nothing
309#endif
310 , ms_srcimps = [] -- source imports are not allowed
311 , ms_parsed_mod = Nothing
312 }
314-- | Run CPP on a file
315runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
316runCpp dflags filename contents = withTempDir $ \dir -> do
317 let out = dir </> takeFileName filename <.> "out"
318 case contents of
319 Nothing -> do
320 -- Happy case, file is not modified, so run CPP on it in-place
321 -- which also makes things like relative #include files work
322 -- and means location information is correct
323 doCpp dflags True filename out
324 liftIO $ SB.hGetStringBuffer out
326 Just contents -> do
327 -- Sad path, we have to create a version of the path in a temp dir
328 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
330 -- Relative includes aren't going to work, so we fix that by adding to the include path.
331 let addSelf (IncludeSpecs quote global) = IncludeSpecs (takeDirectory filename : quote) global
332 dflags <- return dflags{includePaths = addSelf $ includePaths dflags}
334 -- Location information is wrong, so we fix that by patching it afterwards.
335 let inp = dir </> "___HIE_CORE_MAGIC___"
336 withBinaryFile inp WriteMode $ \h ->
337 hPutStringBuffer h contents
338 doCpp dflags True inp out
340 -- Fix up the filename in lines like:
341 -- # 1 "C:/Temp/extra-dir-914611385186/___HIE_CORE_MAGIC___"
342 let tweak x
343 | Just x <- stripPrefix "# " x
344 , "___HIE_CORE_MAGIC___" `isInfixOf` x
345 , let num = takeWhile (not . isSpace) x
346 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
347 -- and GHC gets all confused
348 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
349 | otherwise = x
350 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
353-- | Given a buffer, flags, file path and module summary, produce a
354-- parsed module (or errors) and any parse warnings.
355parseFileContents
356 :: GhcMonad m
357 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
358 -> FilePath -- ^ the filename (for source locations)
359 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
360 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
361parseFileContents preprocessor filename mbContents = do
362 contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
363 let loc = mkRealSrcLoc (mkFastString filename) 1 1
364 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
366 (contents, dflags) <-
367 if not $ xopt LangExt.Cpp dflags then
368 return (contents, dflags)
369 else do
370 contents <- liftIO $ runCpp dflags filename mbContents
371 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
372 return (contents, dflags)
374 case unP Parser.parseModule (mkPState dflags contents loc) of
375 PFailed _ locErr msgErr ->
376 throwE $ diagFromErrMsg dflags $ mkPlainErrMsg dflags locErr msgErr
377 POk pst rdr_module ->
378 let hpm_annotations =
379 (Map.fromListWith (++) $ annotations pst,
380 Map.fromList ((noSrcSpan,comment_q pst)
381 :annotations_comments pst))
382 (warns, errs) = getMessages pst dflags
383 in
384 do
385 -- Just because we got a `POk`, it doesn't mean there
386 -- weren't errors! To clarify, the GHC parser
387 -- distinguishes between fatal and non-fatal
388 -- errors. Non-fatal errors are the sort that don't
389 -- prevent parsing from continuing (that is, a parse
390 -- tree can still be produced despite the error so that
391 -- further errors/warnings can be collected). Fatal
392 -- errors are those from which a parse tree just can't
393 -- be produced.
394 unless (null errs) $
395 throwE $ diagFromErrMsgs dflags $ snd $ getMessages pst dflags
397 -- Ok, we got here. It's safe to continue.
398 let (errs, parsed) = preprocessor rdr_module
399 unless (null errs) $ throwE $ diagFromStrings errs
400 ms <- getModSummaryFromBuffer filename contents dflags parsed
401 let pm =
402 ParsedModule {
403 pm_mod_summary = ms
404 , pm_parsed_source = parsed
405 , pm_extra_src_files=[] -- src imports not allowed
406 , pm_annotations = hpm_annotations
407 }
408 warnings = diagFromErrMsgs dflags warns
409 pure (warnings, pm)
412-- | This reads the pragma information directly from the provided buffer.
413parsePragmasIntoDynFlags
414 :: GhcMonad m
415 => FilePath
416 -> SB.StringBuffer
417 -> m (Either [FileDiagnostic] DynFlags)
418parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
419 dflags0 <- getSessionDynFlags
420 let opts = Hdr.getOptions dflags0 contents fp
421 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
422 return dflags
424-- | Run something in a Ghc monad and catch the errors (SourceErrors and
425-- compiler-internal exceptions like Panic or InstallationError).
426catchSrcErrors :: GhcMonad m => m a -> m (Either [FileDiagnostic] a)
427catchSrcErrors ghcM = do
428 dflags <- getDynFlags
429 handleGhcException (ghcExceptionToDiagnostics dflags) $
430 handleSourceError (sourceErrorToDiagnostics dflags) $
431 Right <$> ghcM
432 where
433 ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException dflags
434 sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs dflags . srcErrorMessages