git.iko.soy/ghcide
on 405d62b help sign in
ghcide/src/Development/IDE/Core/Compile.hs
389 lines 16 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE CPP #-}
7-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
8-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
9module Development.IDE.Core.Compile
10 ( TcModuleResult(..)
11 , compileModule
12 , parseModule
13 , typecheckModule
14 , computePackageDeps
15 , addRelativeImport
16 ) where
18import Development.IDE.Core.RuleTypes
19import Development.IDE.GHC.CPP
20import Development.IDE.GHC.Error
21import Development.IDE.GHC.Warnings
22import Development.IDE.Types.Diagnostics
23import Development.IDE.GHC.Orphans()
24import Development.IDE.GHC.Util
25import Development.IDE.GHC.Compat
26import qualified GHC.LanguageExtensions.Type as GHC
27import Development.IDE.Types.Options
28import Development.IDE.Types.Location
30import GHC hiding (parseModule, typecheckModule)
31import qualified Parser
32import Lexer
33import ErrUtils
35import qualified GHC
36import Panic
37import GhcMonad
38import GhcPlugins as GHC hiding (fst3, (<>))
39import qualified HeaderInfo as Hdr
40import MkIface
41import StringBuffer as SB
42import TidyPgm
43import qualified GHC.LanguageExtensions as LangExt
45import Control.Monad.Extra
46import Control.Monad.Except
47import Control.Monad.Trans.Except
48import Data.Function
49import Data.Ord
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 System.FilePath
57import System.IO.Extra
58import Data.Char
60-- | Given a string buffer, return a pre-processed @ParsedModule@.
61parseModule
62 :: IdeOptions
63 -> HscEnv
64 -> FilePath
65 -> Maybe SB.StringBuffer
66 -> IO ([FileDiagnostic], Maybe ParsedModule)
67parseModule IdeOptions{..} env file =
68 fmap (either (, Nothing) (second Just)) .
69 -- We need packages since imports fail to resolve otherwise.
70 runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
73-- | Given a package identifier, what packages does it depend on
74computePackageDeps
75 :: HscEnv
76 -> InstalledUnitId
77 -> IO (Either [FileDiagnostic] [InstalledUnitId])
78computePackageDeps env pkg = do
79 let dflags = hsc_dflags env
80 case lookupInstalledPackage dflags pkg of
81 Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
82 T.pack $ "unknown package: " ++ show pkg]
83 Just pkgInfo -> return $ Right $ depends pkgInfo
86-- | Typecheck a single module using the supplied dependencies and packages.
87typecheckModule
88 :: HscEnv
89 -> [TcModuleResult]
90 -> ParsedModule
91 -> IO ([FileDiagnostic], Maybe TcModuleResult)
92typecheckModule packageState deps pm =
93 fmap (either (, Nothing) (second Just)) $
94 runGhcEnv packageState $
95 catchSrcErrors "typecheck" $ do
96 setupEnv deps
97 (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
98 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
99 tcm2 <- mkTcModuleResult tcm
100 return (warnings, tcm2)
102-- | Compile a single type-checked module to a 'CoreModule' value, or
103-- provide errors.
104compileModule
105 :: HscEnv
106 -> [TcModuleResult]
107 -> TcModuleResult
108 -> IO ([FileDiagnostic], Maybe CoreModule)
109compileModule packageState deps tmr =
110 fmap (either (, Nothing) (second Just)) $
111 runGhcEnv packageState $
112 catchSrcErrors "compile" $ do
113 setupEnv (deps ++ [tmr])
115 let tm = tmrModule tmr
116 session <- getSession
117 (warnings,desugar) <- withWarnings "compile" $ \tweak -> do
118 let pm = tm_parsed_module tm
119 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
120 let tm' = tm{tm_parsed_module = pm'}
121 GHC.dm_core_module <$> GHC.desugarModule tm'
123 -- give variables unique OccNames
124 (tidy, details) <- liftIO $ tidyProgram session desugar
126 let core = CoreModule
127 (cg_module tidy)
128 (md_types details)
129 (cg_binds tidy)
130 (mg_safe_haskell desugar)
132 return (warnings, core)
135addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
136addRelativeImport modu dflags = dflags
137 {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
139mkTcModuleResult
140 :: GhcMonad m
141 => TypecheckedModule
142 -> m TcModuleResult
143mkTcModuleResult tcm = do
144 session <- getSession
145 (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
146 let mod_info = HomeModInfo iface details Nothing
147 return $ TcModuleResult tcm mod_info
148 where
149 (tcGblEnv, details) = tm_internals_ tcm
151-- | Setup the environment that GHC needs according to our
152-- best understanding (!)
153setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
154setupEnv tmsIn = do
155 -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
156 -- takes precedence, so put the .hs-boot file earlier in the list
157 let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
158 tms = sortBy (compare `on` Down . isSourceFile) tmsIn
160 session <- getSession
162 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
164 -- set the target and module graph in the session
165 let graph = mkModuleGraph mss
166 setSession session { hsc_mod_graph = graph }
168 -- Make modules available for others that import them,
169 -- by putting them in the finder cache.
170 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
171 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
172 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
173 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
174 $ zip ims ifrs
176 -- load dependent modules, which must be in topological order.
177 mapM_ loadModuleHome tms
180-- | Load a module, quickly. Input doesn't need to be desugared.
181-- A module must be loaded before dependent modules can be typechecked.
182-- This variant of loadModuleHome will *never* cause recompilation, it just
183-- modifies the session.
184loadModuleHome
185 :: (GhcMonad m)
186 => TcModuleResult
187 -> m ()
188loadModuleHome tmr = modifySession $ \e ->
189 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
190 where
191 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
192 mod_info = tmrModInfo tmr
193 mod = ms_mod_name ms
197-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
198-- name and its imports.
199getImportsParsed :: DynFlags ->
200 GHC.ParsedSource ->
201 Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
202getImportsParsed dflags (L loc parsed) = do
203 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
205 -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
206 -- but we want to avoid parsing the module twice
207 let implicit_prelude = xopt GHC.ImplicitPrelude dflags
208 implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
210 -- filter out imports that come from packages
211 return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
212 | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
213 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
214 ])
217-- | Produce a module summary from a StringBuffer.
218getModSummaryFromBuffer
219 :: GhcMonad m
220 => FilePath
221 -> SB.StringBuffer
222 -> DynFlags
223 -> GHC.ParsedSource
224 -> ExceptT [FileDiagnostic] m ModSummary
225getModSummaryFromBuffer fp contents dflags parsed = do
226 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
228 let modLoc = ModLocation
229 { ml_hs_file = Just fp
230 , ml_hi_file = derivedFile "hi"
231 , ml_obj_file = derivedFile "o"
232#ifndef GHC_STABLE
233 , ml_hie_file = derivedFile "hie"
234#endif
235 -- This does not consider the dflags configuration
236 -- (-osuf and -hisuf, object and hi dir.s).
237 -- However, we anyway don't want to generate them.
238 }
239 InstalledUnitId unitId = thisInstalledUnitId dflags
240 return $ ModSummary
241 { ms_mod = mkModule (fsToUnitId unitId) modName
242 , ms_location = modLoc
243 , ms_hs_date = error "Rules should not depend on ms_hs_date"
244 -- When we are working with a virtual file we do not have a file date.
245 -- To avoid silent issues where something is not processed because the date
246 -- has not changed, we make sure that things blow up if they depend on the
247 -- date.
248 , ms_textual_imps = [imp | (False, imp) <- imports]
249 , ms_hspp_file = fp
250 , ms_hspp_opts = dflags
251 , ms_hspp_buf = Just contents
253 -- defaults:
254 , ms_hsc_src = sourceType
255 , ms_obj_date = Nothing
256 , ms_iface_date = Nothing
257#ifndef GHC_STABLE
258 , ms_hie_date = Nothing
259#endif
260 , ms_srcimps = [imp | (True, imp) <- imports]
261 , ms_parsed_mod = Nothing
262 }
263 where
264 (sourceType, derivedFile) =
265 let (stem, ext) = splitExtension fp in
266 if "-boot" `isSuffixOf` ext
267 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
268 else (HsSrcFile , \newExt -> stem <.> newExt)
270-- | Run CPP on a file
271runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
272runCpp dflags filename contents = withTempDir $ \dir -> do
273 let out = dir </> takeFileName filename <.> "out"
274 case contents of
275 Nothing -> do
276 -- Happy case, file is not modified, so run CPP on it in-place
277 -- which also makes things like relative #include files work
278 -- and means location information is correct
279 doCpp dflags True filename out
280 liftIO $ SB.hGetStringBuffer out
282 Just contents -> do
283 -- Sad path, we have to create a version of the path in a temp dir
284 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
286 -- Relative includes aren't going to work, so we fix that by adding to the include path.
287 dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
289 -- Location information is wrong, so we fix that by patching it afterwards.
290 let inp = dir </> "___GHCIDE_MAGIC___"
291 withBinaryFile inp WriteMode $ \h ->
292 hPutStringBuffer h contents
293 doCpp dflags True inp out
295 -- Fix up the filename in lines like:
296 -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
297 let tweak x
298 | Just x <- stripPrefix "# " x
299 , "___GHCIDE_MAGIC___" `isInfixOf` x
300 , let num = takeWhile (not . isSpace) x
301 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
302 -- and GHC gets all confused
303 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
304 | otherwise = x
305 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
308-- | Given a buffer, flags, file path and module summary, produce a
309-- parsed module (or errors) and any parse warnings.
310parseFileContents
311 :: GhcMonad m
312 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
313 -> FilePath -- ^ the filename (for source locations)
314 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
315 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
316parseFileContents preprocessor filename mbContents = do
317 contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
318 let loc = mkRealSrcLoc (mkFastString filename) 1 1
319 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
321 (contents, dflags) <-
322 if not $ xopt LangExt.Cpp dflags then
323 return (contents, dflags)
324 else do
325 contents <- liftIO $ runCpp dflags filename mbContents
326 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
327 return (contents, dflags)
329 case unP Parser.parseModule (mkPState dflags contents loc) of
330 PFailed _ locErr msgErr ->
331 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
332 POk pst rdr_module ->
333 let hpm_annotations =
334 (Map.fromListWith (++) $ annotations pst,
335 Map.fromList ((noSrcSpan,comment_q pst)
336 :annotations_comments pst))
337 (warns, errs) = getMessages pst dflags
338 in
339 do
340 -- Just because we got a `POk`, it doesn't mean there
341 -- weren't errors! To clarify, the GHC parser
342 -- distinguishes between fatal and non-fatal
343 -- errors. Non-fatal errors are the sort that don't
344 -- prevent parsing from continuing (that is, a parse
345 -- tree can still be produced despite the error so that
346 -- further errors/warnings can be collected). Fatal
347 -- errors are those from which a parse tree just can't
348 -- be produced.
349 unless (null errs) $
350 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
352 -- Ok, we got here. It's safe to continue.
353 let (errs, parsed) = preprocessor rdr_module
354 unless (null errs) $ throwE $ diagFromStrings "parser" errs
355 ms <- getModSummaryFromBuffer filename contents dflags parsed
356 let pm =
357 ParsedModule {
358 pm_mod_summary = ms
359 , pm_parsed_source = parsed
360 , pm_extra_src_files=[] -- src imports not allowed
361 , pm_annotations = hpm_annotations
362 }
363 warnings = diagFromErrMsgs "parser" dflags warns
364 pure (warnings, pm)
367-- | This reads the pragma information directly from the provided buffer.
368parsePragmasIntoDynFlags
369 :: GhcMonad m
370 => FilePath
371 -> SB.StringBuffer
372 -> m (Either [FileDiagnostic] DynFlags)
373parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
374 dflags0 <- getSessionDynFlags
375 let opts = Hdr.getOptions dflags0 contents fp
376 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
377 return dflags
379-- | Run something in a Ghc monad and catch the errors (SourceErrors and
380-- compiler-internal exceptions like Panic or InstallationError).
381catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
382catchSrcErrors fromWhere ghcM = do
383 dflags <- getDynFlags
384 handleGhcException (ghcExceptionToDiagnostics dflags) $
385 handleSourceError (sourceErrorToDiagnostics dflags) $
386 Right <$> ghcM
387 where
388 ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
389 sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages