git.iko.soy/ghcide
on b2380ea help sign in
ghcide/src/Development/IDE/Core/Compile.hs
401 lines 16 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 , compileModule
13 , parseModule
14 , typecheckModule
15 , computePackageDeps
16 , addRelativeImport
17 ) where
19import Development.IDE.Core.RuleTypes
20import Development.IDE.GHC.CPP
21import Development.IDE.GHC.Error
22import Development.IDE.GHC.Warnings
23import Development.IDE.Types.Diagnostics
24import Development.IDE.GHC.Orphans()
25import Development.IDE.GHC.Util
26import Development.IDE.GHC.Compat
27import qualified GHC.LanguageExtensions.Type as GHC
28import Development.IDE.Types.Options
29import Development.IDE.Types.Location
31import GHC hiding (parseModule, typecheckModule)
32import qualified Parser
33import Lexer
34import ErrUtils
36import qualified GHC
37import Panic
38import GhcMonad
39import GhcPlugins as GHC hiding (fst3, (<>))
40import qualified HeaderInfo as Hdr
41import MkIface
42import StringBuffer as SB
43import TidyPgm
44import qualified GHC.LanguageExtensions as LangExt
46import Control.Monad.Extra
47import Control.Monad.Except
48import Control.Monad.Trans.Except
49import qualified Data.Text as T
50import Data.IORef
51import Data.List.Extra
52import Data.Maybe
53import Data.Tuple.Extra
54import qualified Data.Map.Strict as Map
55import System.FilePath
56import System.Directory
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 :: IdeOptions
89 -> HscEnv
90 -> [TcModuleResult]
91 -> ParsedModule
92 -> IO ([FileDiagnostic], Maybe TcModuleResult)
93typecheckModule opt packageState deps pm =
94 fmap (either (, Nothing) (second Just)) $
95 runGhcEnv packageState $
96 catchSrcErrors $ do
97 setupEnv deps
98 (warnings, tcm) <- withWarnings $ \tweak ->
99 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
100 tcm2 <- mkTcModuleResult (optIfaceDir opt) tcm
101 return (warnings, tcm2)
103-- | Compile a single type-checked module to a 'CoreModule' value, or
104-- provide errors.
105compileModule
106 :: HscEnv
107 -> [TcModuleResult]
108 -> TcModuleResult
109 -> IO ([FileDiagnostic], Maybe CoreModule)
110compileModule packageState deps tmr =
111 fmap (either (, Nothing) (second Just)) $
112 runGhcEnv packageState $
113 catchSrcErrors $ do
114 setupEnv (deps ++ [tmr])
116 let tm = tmrModule tmr
117 session <- getSession
118 (warnings,desugar) <- withWarnings $ \tweak -> do
119 let pm = tm_parsed_module tm
120 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
121 let tm' = tm{tm_parsed_module = pm'}
122 GHC.dm_core_module <$> GHC.desugarModule tm'
124 -- give variables unique OccNames
125 (tidy, details) <- liftIO $ tidyProgram session desugar
127 let core = CoreModule
128 (cg_module tidy)
129 (md_types details)
130 (cg_binds tidy)
131 (mg_safe_haskell desugar)
133 return (warnings, core)
136addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
137addRelativeImport modu dflags = dflags
138 {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
140mkTcModuleResult
141 :: GhcMonad m
142 => InterfaceDirectory
143 -> TypecheckedModule
144 -> m TcModuleResult
145mkTcModuleResult (InterfaceDirectory mbIfaceDir) tcm = do
146 session <- getSession
147 (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
148 liftIO $ whenJust mbIfaceDir $ \ifaceDir -> do
149 let path = ifaceDir </> file tcm
150 createDirectoryIfMissing True (takeDirectory path)
151 writeIfaceFile (hsc_dflags session) (replaceExtension path ".hi") iface
152 -- For now, we write .hie files whenever we write .hi files which roughly corresponds to
153 -- when we are building a package. It should be easily decoupable if that turns out to be
154 -- useful.
155 hieFile <- runHsc session $ mkHieFile (tcModSummary tcm) tcGblEnv (fromJust $ renamedSource tcm)
156 writeHieFile (replaceExtension path ".hie") hieFile
157 let mod_info = HomeModInfo iface details Nothing
158 return $ TcModuleResult tcm mod_info
159 where
160 file = ms_hspp_file . tcModSummary
161 (tcGblEnv, details) = tm_internals_ tcm
163tcModSummary :: TypecheckedModule -> ModSummary
164tcModSummary = pm_mod_summary . tm_parsed_module
166-- | Setup the environment that GHC needs according to our
167-- best understanding (!)
168setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
169setupEnv tms = do
170 session <- getSession
172 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
174 -- set the target and module graph in the session
175 let graph = mkModuleGraph mss
176 setSession session { hsc_mod_graph = graph }
178 -- Make modules available for others that import them,
179 -- by putting them in the finder cache.
180 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
181 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
182 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
183 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
184 $ zip ims ifrs
186 -- load dependent modules, which must be in topological order.
187 mapM_ loadModuleHome tms
190-- | Load a module, quickly. Input doesn't need to be desugared.
191-- A module must be loaded before dependent modules can be typechecked.
192-- This variant of loadModuleHome will *never* cause recompilation, it just
193-- modifies the session.
194loadModuleHome
195 :: (GhcMonad m)
196 => TcModuleResult
197 -> m ()
198loadModuleHome tmr = modifySession $ \e ->
199 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
200 where
201 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
202 mod_info = tmrModInfo tmr
203 mod = ms_mod_name ms
207-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
208-- name and its imports.
209getImportsParsed :: DynFlags ->
210 GHC.ParsedSource ->
211 Either [FileDiagnostic] (GHC.ModuleName, [(Maybe FastString, Located GHC.ModuleName)])
212getImportsParsed dflags (L loc parsed) = do
213 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
215 -- refuse source imports
216 let srcImports = filter (ideclSource . GHC.unLoc) $ GHC.hsmodImports parsed
217 when (not $ null srcImports) $ Left $
218 concat
219 [ diagFromString mloc ("Illegal source import of " <> GHC.moduleNameString (GHC.unLoc $ GHC.ideclName i))
220 | L mloc i <- srcImports ]
222 -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
223 -- but we want to avoid parsing the module twice
224 let implicit_prelude = xopt GHC.ImplicitPrelude dflags
225 implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
227 -- filter out imports that come from packages
228 return (modName, [(fmap sl_fs $ ideclPkgQual i, ideclName i)
229 | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
230 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
231 ])
234-- | Produce a module summary from a StringBuffer.
235getModSummaryFromBuffer
236 :: GhcMonad m
237 => FilePath
238 -> SB.StringBuffer
239 -> DynFlags
240 -> GHC.ParsedSource
241 -> ExceptT [FileDiagnostic] m ModSummary
242getModSummaryFromBuffer fp contents dflags parsed = do
243 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
245 let modLoc = ModLocation
246 { ml_hs_file = Just fp
247 , ml_hi_file = replaceExtension fp "hi"
248 , ml_obj_file = replaceExtension fp "o"
249#ifndef GHC_STABLE
250 , ml_hie_file = replaceExtension fp "hie"
251#endif
252 -- This does not consider the dflags configuration
253 -- (-osuf and -hisuf, object and hi dir.s).
254 -- However, we anyway don't want to generate them.
255 }
256 InstalledUnitId unitId = thisInstalledUnitId dflags
257 return $ ModSummary
258 { ms_mod = mkModule (fsToUnitId unitId) modName
259 , ms_location = modLoc
260 , ms_hs_date = error "Rules should not depend on ms_hs_date"
261 -- When we are working with a virtual file we do not have a file date.
262 -- To avoid silent issues where something is not processed because the date
263 -- has not changed, we make sure that things blow up if they depend on the
264 -- date.
265 , ms_textual_imps = imports
266 , ms_hspp_file = fp
267 , ms_hspp_opts = dflags
268 , ms_hspp_buf = Just contents
270 -- defaults:
271 , ms_hsc_src = HsSrcFile
272 , ms_obj_date = Nothing
273 , ms_iface_date = Nothing
274#ifndef GHC_STABLE
275 , ms_hie_date = Nothing
276#endif
277 , ms_srcimps = [] -- source imports are not allowed
278 , ms_parsed_mod = Nothing
279 }
281-- | Run CPP on a file
282runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
283runCpp dflags filename contents = withTempDir $ \dir -> do
284 let out = dir </> takeFileName filename <.> "out"
285 case contents of
286 Nothing -> do
287 -- Happy case, file is not modified, so run CPP on it in-place
288 -- which also makes things like relative #include files work
289 -- and means location information is correct
290 doCpp dflags True filename out
291 liftIO $ SB.hGetStringBuffer out
293 Just contents -> do
294 -- Sad path, we have to create a version of the path in a temp dir
295 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
297 -- Relative includes aren't going to work, so we fix that by adding to the include path.
298 let addSelf (IncludeSpecs quote global) = IncludeSpecs (takeDirectory filename : quote) global
299 dflags <- return dflags{includePaths = addSelf $ includePaths dflags}
301 -- Location information is wrong, so we fix that by patching it afterwards.
302 let inp = dir </> "___HIE_CORE_MAGIC___"
303 withBinaryFile inp WriteMode $ \h ->
304 hPutStringBuffer h contents
305 doCpp dflags True inp out
307 -- Fix up the filename in lines like:
308 -- # 1 "C:/Temp/extra-dir-914611385186/___HIE_CORE_MAGIC___"
309 let tweak x
310 | Just x <- stripPrefix "# " x
311 , "___HIE_CORE_MAGIC___" `isInfixOf` x
312 , let num = takeWhile (not . isSpace) x
313 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
314 -- and GHC gets all confused
315 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
316 | otherwise = x
317 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
320-- | Given a buffer, flags, file path and module summary, produce a
321-- parsed module (or errors) and any parse warnings.
322parseFileContents
323 :: GhcMonad m
324 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
325 -> FilePath -- ^ the filename (for source locations)
326 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
327 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
328parseFileContents preprocessor filename mbContents = do
329 contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
330 let loc = mkRealSrcLoc (mkFastString filename) 1 1
331 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
333 (contents, dflags) <-
334 if not $ xopt LangExt.Cpp dflags then
335 return (contents, dflags)
336 else do
337 contents <- liftIO $ runCpp dflags filename mbContents
338 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
339 return (contents, dflags)
341 case unP Parser.parseModule (mkPState dflags contents loc) of
342 PFailed _ locErr msgErr ->
343 throwE $ diagFromErrMsg dflags $ mkPlainErrMsg dflags locErr msgErr
344 POk pst rdr_module ->
345 let hpm_annotations =
346 (Map.fromListWith (++) $ annotations pst,
347 Map.fromList ((noSrcSpan,comment_q pst)
348 :annotations_comments pst))
349 (warns, errs) = getMessages pst dflags
350 in
351 do
352 -- Just because we got a `POk`, it doesn't mean there
353 -- weren't errors! To clarify, the GHC parser
354 -- distinguishes between fatal and non-fatal
355 -- errors. Non-fatal errors are the sort that don't
356 -- prevent parsing from continuing (that is, a parse
357 -- tree can still be produced despite the error so that
358 -- further errors/warnings can be collected). Fatal
359 -- errors are those from which a parse tree just can't
360 -- be produced.
361 unless (null errs) $
362 throwE $ diagFromErrMsgs dflags $ snd $ getMessages pst dflags
364 -- Ok, we got here. It's safe to continue.
365 let (errs, parsed) = preprocessor rdr_module
366 unless (null errs) $ throwE $ diagFromStrings errs
367 ms <- getModSummaryFromBuffer filename contents dflags parsed
368 let pm =
369 ParsedModule {
370 pm_mod_summary = ms
371 , pm_parsed_source = parsed
372 , pm_extra_src_files=[] -- src imports not allowed
373 , pm_annotations = hpm_annotations
374 }
375 warnings = diagFromErrMsgs dflags warns
376 pure (warnings, pm)
379-- | This reads the pragma information directly from the provided buffer.
380parsePragmasIntoDynFlags
381 :: GhcMonad m
382 => FilePath
383 -> SB.StringBuffer
384 -> m (Either [FileDiagnostic] DynFlags)
385parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
386 dflags0 <- getSessionDynFlags
387 let opts = Hdr.getOptions dflags0 contents fp
388 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
389 return dflags
391-- | Run something in a Ghc monad and catch the errors (SourceErrors and
392-- compiler-internal exceptions like Panic or InstallationError).
393catchSrcErrors :: GhcMonad m => m a -> m (Either [FileDiagnostic] a)
394catchSrcErrors ghcM = do
395 dflags <- getDynFlags
396 handleGhcException (ghcExceptionToDiagnostics dflags) $
397 handleSourceError (sourceErrorToDiagnostics dflags) $
398 Right <$> ghcM
399 where
400 ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException dflags
401 sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs dflags . srcErrorMessages