1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE RankNTypes #-}
6#include "ghc-api-version.h"
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
21import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Preprocessor
23import Development.IDE.GHC.Error
24import Development.IDE.GHC.Warnings
25import Development.IDE.Types.Diagnostics
26import Development.IDE.GHC.Orphans()
27import Development.IDE.GHC.Util
28import qualified GHC.LanguageExtensions.Type as GHC
29import Development.IDE.Types.Options
30import Development.IDE.Types.Location
32#if MIN_GHC_API_VERSION(8,6,0)
33import DynamicLoading (initializePlugins)
36import GHC hiding (parseModule, typecheckModule)
37import qualified Parser
43import GhcPlugins as GHC hiding (fst3, (<>))
44import qualified HeaderInfo as Hdr
45import HscMain (hscInteractive)
47import StringBuffer as SB
50import Control.Monad.Extra
51import Control.Monad.Except
52import Control.Monad.Trans.Except
55import qualified Data.Text as T
59import Data.Tuple.Extra
60import qualified Data.Map.Strict as Map
64-- | Given a string buffer, return a pre-processed @ParsedModule@.
69 -> Maybe SB.StringBuffer
70 -> IO ([FileDiagnostic], Maybe ParsedModule)
71parseModule IdeOptions{..} env file =
72 fmap (either (, Nothing) (second Just)) .
73 -- We need packages since imports fail to resolve otherwise.
74 runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
77-- | Given a package identifier, what packages does it depend on
81 -> IO (Either [FileDiagnostic] [InstalledUnitId])
82computePackageDeps env pkg = do
83 let dflags = hsc_dflags env
84 case lookupInstalledPackage dflags pkg of
85 Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
86 T.pack $ "unknown package: " ++ show pkg]
87 Just pkgInfo -> return $ Right $ depends pkgInfo
90-- | Typecheck a single module using the supplied dependencies and packages.
96 -> IO ([FileDiagnostic], Maybe TcModuleResult)
97typecheckModule (IdeDefer defer) packageState deps pm =
98 let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
100 fmap (either (, Nothing) (second Just)) $
101 runGhcEnv packageState $
102 catchSrcErrors "typecheck" $ do
104 let modSummary = pm_mod_summary pm
105 dflags = ms_hspp_opts modSummary
106 modSummary' <- initPlugins modSummary
107 (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
108 GHC.typecheckModule $ enableTopLevelWarnings
109 $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
110 tcm2 <- mkTcModuleResult tcm
111 let errorPipeline = unDefer . hideDiag dflags
112 return (map errorPipeline warnings, tcm2)
114initPlugins :: GhcMonad m => ModSummary -> m ModSummary
115initPlugins modSummary = do
116#if MIN_GHC_API_VERSION(8,6,0)
117 session <- getSession
118 dflags <- liftIO $ initializePlugins session (ms_hspp_opts modSummary)
119 return modSummary{ms_hspp_opts = dflags}
124-- | Compile a single type-checked module to a 'CoreModule' value, or
130 -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
131compileModule packageState deps tmr =
132 fmap (either (, Nothing) (second Just)) $
133 runGhcEnv packageState $
134 catchSrcErrors "compile" $ do
135 setupEnv (deps ++ [tmr])
137 let tm = tmrModule tmr
138 session <- getSession
139 (warnings,desugar) <- withWarnings "compile" $ \tweak -> do
140 let pm = tm_parsed_module tm
141 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
142 let tm' = tm{tm_parsed_module = pm'}
143 GHC.dm_core_module <$> GHC.desugarModule tm'
145 -- give variables unique OccNames
146 (guts, details) <- liftIO $ tidyProgram session desugar
147 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
149generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
150generateByteCode hscEnv deps tmr guts =
151 fmap (either (, Nothing) (second Just)) $
153 catchSrcErrors "bytecode" $ do
154 setupEnv (deps ++ [tmr])
155 session <- getSession
156 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
157 liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
158 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
159 let unlinked = BCOs bytecode sptEntries
160 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
161 pure (map snd warnings, linkable)
163demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
164demoteTypeErrorsToWarnings =
165 (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where
167 demoteTEsToWarns :: DynFlags -> DynFlags
168 -- convert the errors into warnings, and also check the warnings are enabled
169 demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)
170 . (`wopt_set` Opt_WarnTypedHoles)
171 . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)
172 . (`gopt_set` Opt_DeferTypeErrors)
173 . (`gopt_set` Opt_DeferTypedHoles)
174 . (`gopt_set` Opt_DeferOutOfScopeVariables)
176enableTopLevelWarnings :: ParsedModule -> ParsedModule
177enableTopLevelWarnings =
178 (update_pm_mod_summary . update_hspp_opts)
179 (`wopt_set` Opt_WarnMissingSignatures)
180 -- the line below would show also warnings for let bindings without signature
181 -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
183update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
184update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
186update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
187update_pm_mod_summary up pm =
188 pm{pm_mod_summary = up $ pm_mod_summary pm}
190unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
191unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
192unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError fd
193unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd
194unDefer ( _ , fd) = fd
196upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
197upgradeWarningToError (nfp, sh, fd) =
198 (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
199 warn2err :: T.Text -> T.Text
200 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
202hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
203hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
204 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
205hideDiag _originalFlags t = t
207addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
208addRelativeImport fp modu dflags = dflags
209 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
215mkTcModuleResult tcm = do
216 session <- getSession
217 (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
218 let mod_info = HomeModInfo iface details Nothing
219 return $ TcModuleResult tcm mod_info
221 (tcGblEnv, details) = tm_internals_ tcm
223-- | Setup the environment that GHC needs according to our
224-- best understanding (!)
225setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
227 -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
228 -- takes precedence, so put the .hs-boot file earlier in the list
229 let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
230 tms = sortBy (compare `on` Down . isSourceFile) tmsIn
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 -- We have to create a new IORef here instead of modifying the existing IORef as
245 -- it is shared between concurrent compilations.
246 prevFinderCache <- liftIO $ readIORef $ hsc_FC session
249 (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache
251 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
252 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
254 -- load dependent modules, which must be in topological order.
255 mapM_ loadModuleHome tms
258-- | Load a module, quickly. Input doesn't need to be desugared.
259-- A module must be loaded before dependent modules can be typechecked.
260-- This variant of loadModuleHome will *never* cause recompilation, it just
261-- modifies the session.
266loadModuleHome tmr = modifySession $ \e ->
267 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
269 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
270 mod_info = tmrModInfo tmr
275-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
276-- name and its imports.
277getImportsParsed :: DynFlags ->
279 Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
280getImportsParsed dflags (L loc parsed) = do
281 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
283 -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
284 -- but we want to avoid parsing the module twice
285 let implicit_prelude = xopt GHC.ImplicitPrelude dflags
286 implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
288 -- filter out imports that come from packages
289 return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
290 | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
291 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
295-- | Produce a module summary from a StringBuffer.
296getModSummaryFromBuffer
302 -> ExceptT [FileDiagnostic] m ModSummary
303getModSummaryFromBuffer fp contents dflags parsed = do
304 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
306 let modLoc = ModLocation
307 { ml_hs_file = Just fp
308 , ml_hi_file = derivedFile "hi"
309 , ml_obj_file = derivedFile "o"
310#if MIN_GHC_API_VERSION(8,8,0)
311 , ml_hie_file = derivedFile "hie"
313 -- This does not consider the dflags configuration
314 -- (-osuf and -hisuf, object and hi dir.s).
315 -- However, we anyway don't want to generate them.
317 InstalledUnitId unitId = thisInstalledUnitId dflags
319 { ms_mod = mkModule (fsToUnitId unitId) modName
320 , ms_location = modLoc
321 , ms_hs_date = error "Rules should not depend on ms_hs_date"
322 -- When we are working with a virtual file we do not have a file date.
323 -- To avoid silent issues where something is not processed because the date
324 -- has not changed, we make sure that things blow up if they depend on the
326 , ms_textual_imps = [imp | (False, imp) <- imports]
328 , ms_hspp_opts = dflags
329 , ms_hspp_buf = Just contents
332 , ms_hsc_src = sourceType
333 , ms_obj_date = Nothing
334 , ms_iface_date = Nothing
335#if MIN_GHC_API_VERSION(8,8,0)
336 , ms_hie_date = Nothing
338 , ms_srcimps = [imp | (True, imp) <- imports]
339 , ms_parsed_mod = Nothing
342 (sourceType, derivedFile) =
343 let (stem, ext) = splitExtension fp in
344 if "-boot" `isSuffixOf` ext
345 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
346 else (HsSrcFile , \newExt -> stem <.> newExt)
349-- | Given a buffer, flags, file path and module summary, produce a
350-- parsed module (or errors) and any parse warnings.
353 => (GHC.ParsedSource -> IdePreprocessedSource)
354 -> FilePath -- ^ the filename (for source locations)
355 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
356 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
357parseFileContents customPreprocessor filename mbContents = do
358 (contents, dflags) <- preprocessor filename mbContents
359 let loc = mkRealSrcLoc (mkFastString filename) 1 1
360 case unP Parser.parseModule (mkPState dflags contents loc) of
361 PFailed _ locErr msgErr ->
362 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
363 POk pst rdr_module ->
364 let hpm_annotations =
365 (Map.fromListWith (++) $ annotations pst,
366 Map.fromList ((noSrcSpan,comment_q pst)
367 :annotations_comments pst))
368 (warns, errs) = getMessages pst dflags
371 -- Just because we got a `POk`, it doesn't mean there
372 -- weren't errors! To clarify, the GHC parser
373 -- distinguishes between fatal and non-fatal
374 -- errors. Non-fatal errors are the sort that don't
375 -- prevent parsing from continuing (that is, a parse
376 -- tree can still be produced despite the error so that
377 -- further errors/warnings can be collected). Fatal
378 -- errors are those from which a parse tree just can't
381 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
383 -- Ok, we got here. It's safe to continue.
384 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
385 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
386 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
387 ms <- getModSummaryFromBuffer filename contents dflags parsed
391 , pm_parsed_source = parsed
392 , pm_extra_src_files=[] -- src imports not allowed
393 , pm_annotations = hpm_annotations
395 warnings = diagFromErrMsgs "parser" dflags warns
396 pure (warnings ++ preproc_warnings, pm)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list