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