git.iko.soy/ghcide
on de35c8f help sign in
ghcide/src/Development/IDE/Core/Compile.hs
427 lines 17 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
60import SysTools (Option (..), runUnlit)
63-- | Given a string buffer, return a pre-processed @ParsedModule@.
64parseModule
65 :: IdeOptions
66 -> HscEnv
67 -> FilePath
68 -> Maybe SB.StringBuffer
69 -> IO ([FileDiagnostic], Maybe ParsedModule)
70parseModule IdeOptions{..} env file =
71 fmap (either (, Nothing) (second Just)) .
72 -- We need packages since imports fail to resolve otherwise.
73 runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
76-- | Given a package identifier, what packages does it depend on
77computePackageDeps
78 :: HscEnv
79 -> InstalledUnitId
80 -> IO (Either [FileDiagnostic] [InstalledUnitId])
81computePackageDeps env pkg = do
82 let dflags = hsc_dflags env
83 case lookupInstalledPackage dflags pkg of
84 Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
85 T.pack $ "unknown package: " ++ show pkg]
86 Just pkgInfo -> return $ Right $ depends pkgInfo
89-- | Typecheck a single module using the supplied dependencies and packages.
90typecheckModule
91 :: HscEnv
92 -> [TcModuleResult]
93 -> ParsedModule
94 -> IO ([FileDiagnostic], Maybe TcModuleResult)
95typecheckModule packageState deps pm =
96 fmap (either (, Nothing) (second Just)) $
97 runGhcEnv packageState $
98 catchSrcErrors "typecheck" $ do
99 setupEnv deps
100 (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
101 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
102 tcm2 <- mkTcModuleResult tcm
103 return (warnings, tcm2)
105-- | Compile a single type-checked module to a 'CoreModule' value, or
106-- provide errors.
107compileModule
108 :: HscEnv
109 -> [TcModuleResult]
110 -> TcModuleResult
111 -> IO ([FileDiagnostic], Maybe CoreModule)
112compileModule packageState deps tmr =
113 fmap (either (, Nothing) (second Just)) $
114 runGhcEnv packageState $
115 catchSrcErrors "compile" $ do
116 setupEnv (deps ++ [tmr])
118 let tm = tmrModule tmr
119 session <- getSession
120 (warnings,desugar) <- withWarnings "compile" $ \tweak -> do
121 let pm = tm_parsed_module tm
122 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
123 let tm' = tm{tm_parsed_module = pm'}
124 GHC.dm_core_module <$> GHC.desugarModule tm'
126 -- give variables unique OccNames
127 (tidy, details) <- liftIO $ tidyProgram session desugar
129 let core = CoreModule
130 (cg_module tidy)
131 (md_types details)
132 (cg_binds tidy)
133 (mg_safe_haskell desugar)
135 return (warnings, core)
138addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
139addRelativeImport modu dflags = dflags
140 {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
142mkTcModuleResult
143 :: GhcMonad m
144 => TypecheckedModule
145 -> m TcModuleResult
146mkTcModuleResult tcm = do
147 session <- getSession
148 (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
149 let mod_info = HomeModInfo iface details Nothing
150 return $ TcModuleResult tcm mod_info
151 where
152 (tcGblEnv, details) = tm_internals_ tcm
154-- | Setup the environment that GHC needs according to our
155-- best understanding (!)
156setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
157setupEnv tmsIn = do
158 -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
159 -- takes precedence, so put the .hs-boot file earlier in the list
160 let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
161 tms = sortBy (compare `on` Down . isSourceFile) tmsIn
163 session <- getSession
165 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
167 -- set the target and module graph in the session
168 let graph = mkModuleGraph mss
169 setSession session { hsc_mod_graph = graph }
171 -- Make modules available for others that import them,
172 -- by putting them in the finder cache.
173 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
174 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
175 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
176 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
177 $ zip ims ifrs
179 -- load dependent modules, which must be in topological order.
180 mapM_ loadModuleHome tms
183-- | Load a module, quickly. Input doesn't need to be desugared.
184-- A module must be loaded before dependent modules can be typechecked.
185-- This variant of loadModuleHome will *never* cause recompilation, it just
186-- modifies the session.
187loadModuleHome
188 :: (GhcMonad m)
189 => TcModuleResult
190 -> m ()
191loadModuleHome tmr = modifySession $ \e ->
192 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
193 where
194 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
195 mod_info = tmrModInfo tmr
196 mod = ms_mod_name ms
200-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
201-- name and its imports.
202getImportsParsed :: DynFlags ->
203 GHC.ParsedSource ->
204 Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
205getImportsParsed dflags (L loc parsed) = do
206 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
208 -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
209 -- but we want to avoid parsing the module twice
210 let implicit_prelude = xopt GHC.ImplicitPrelude dflags
211 implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
213 -- filter out imports that come from packages
214 return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
215 | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
216 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
217 ])
220-- | Produce a module summary from a StringBuffer.
221getModSummaryFromBuffer
222 :: GhcMonad m
223 => FilePath
224 -> SB.StringBuffer
225 -> DynFlags
226 -> GHC.ParsedSource
227 -> ExceptT [FileDiagnostic] m ModSummary
228getModSummaryFromBuffer fp contents dflags parsed = do
229 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
231 let modLoc = ModLocation
232 { ml_hs_file = Just fp
233 , ml_hi_file = derivedFile "hi"
234 , ml_obj_file = derivedFile "o"
235#ifndef GHC_STABLE
236 , ml_hie_file = derivedFile "hie"
237#endif
238 -- This does not consider the dflags configuration
239 -- (-osuf and -hisuf, object and hi dir.s).
240 -- However, we anyway don't want to generate them.
241 }
242 InstalledUnitId unitId = thisInstalledUnitId dflags
243 return $ ModSummary
244 { ms_mod = mkModule (fsToUnitId unitId) modName
245 , ms_location = modLoc
246 , ms_hs_date = error "Rules should not depend on ms_hs_date"
247 -- When we are working with a virtual file we do not have a file date.
248 -- To avoid silent issues where something is not processed because the date
249 -- has not changed, we make sure that things blow up if they depend on the
250 -- date.
251 , ms_textual_imps = [imp | (False, imp) <- imports]
252 , ms_hspp_file = fp
253 , ms_hspp_opts = dflags
254 , ms_hspp_buf = Just contents
256 -- defaults:
257 , ms_hsc_src = sourceType
258 , ms_obj_date = Nothing
259 , ms_iface_date = Nothing
260#ifndef GHC_STABLE
261 , ms_hie_date = Nothing
262#endif
263 , ms_srcimps = [imp | (True, imp) <- imports]
264 , ms_parsed_mod = Nothing
265 }
266 where
267 (sourceType, derivedFile) =
268 let (stem, ext) = splitExtension fp in
269 if "-boot" `isSuffixOf` ext
270 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
271 else (HsSrcFile , \newExt -> stem <.> newExt)
273-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
274runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
275runLhs dflags filename contents = withTempDir $ \dir -> do
276 let fout = dir </> takeFileName filename <.> "unlit"
277 filesrc <- case contents of
278 Nothing -> return filename
279 Just cnts -> do
280 let fsrc = dir </> takeFileName filename <.> "literate"
281 withBinaryFile fsrc WriteMode $ \h ->
282 hPutStringBuffer h cnts
283 return fsrc
284 unlit filesrc fout
285 SB.hGetStringBuffer fout
286 where
287 unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
288 args filein fileout = [
289 SysTools.Option "-h"
290 , SysTools.Option (escape filename) -- name this file
291 , SysTools.FileOption "" filein -- input file
292 , SysTools.FileOption "" fileout ] -- output file
293 -- taken from ghc's DriverPipeline.hs
294 escape ('\\':cs) = '\\':'\\': escape cs
295 escape ('\"':cs) = '\\':'\"': escape cs
296 escape ('\'':cs) = '\\':'\'': escape cs
297 escape (c:cs) = c : escape cs
298 escape [] = []
300-- | Run CPP on a file
301runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
302runCpp dflags filename contents = withTempDir $ \dir -> do
303 let out = dir </> takeFileName filename <.> "out"
304 case contents of
305 Nothing -> do
306 -- Happy case, file is not modified, so run CPP on it in-place
307 -- which also makes things like relative #include files work
308 -- and means location information is correct
309 doCpp dflags True filename out
310 liftIO $ SB.hGetStringBuffer out
312 Just contents -> do
313 -- Sad path, we have to create a version of the path in a temp dir
314 -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
316 -- Relative includes aren't going to work, so we fix that by adding to the include path.
317 dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
319 -- Location information is wrong, so we fix that by patching it afterwards.
320 let inp = dir </> "___GHCIDE_MAGIC___"
321 withBinaryFile inp WriteMode $ \h ->
322 hPutStringBuffer h contents
323 doCpp dflags True inp out
325 -- Fix up the filename in lines like:
326 -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
327 let tweak x
328 | Just x <- stripPrefix "# " x
329 , "___GHCIDE_MAGIC___" `isInfixOf` x
330 , let num = takeWhile (not . isSpace) x
331 -- important to use /, and never \ for paths, even on Windows, since then C escapes them
332 -- and GHC gets all confused
333 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
334 | otherwise = x
335 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
337-- | Given a buffer, flags, file path and module summary, produce a
338-- parsed module (or errors) and any parse warnings.
339parseFileContents
340 :: GhcMonad m
341 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
342 -> FilePath -- ^ the filename (for source locations)
343 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
344 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
345parseFileContents preprocessor filename mbContents = do
346 let loc = mkRealSrcLoc (mkFastString filename) 1 1
347 contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents
348 let isOnDisk = isNothing mbContents
350 -- unlit content if literate Haskell ending
351 (isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename
352 then do
353 dflags <- getDynFlags
354 newcontent <- liftIO $ runLhs dflags filename mbContents
355 return (False, newcontent)
356 else return (isOnDisk, contents)
358 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
359 (contents, dflags) <-
360 if not $ xopt LangExt.Cpp dflags then
361 return (contents, dflags)
362 else do
363 contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
364 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
365 return (contents, dflags)
367 case unP Parser.parseModule (mkPState dflags contents loc) of
368 PFailed _ locErr msgErr ->
369 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
370 POk pst rdr_module ->
371 let hpm_annotations =
372 (Map.fromListWith (++) $ annotations pst,
373 Map.fromList ((noSrcSpan,comment_q pst)
374 :annotations_comments pst))
375 (warns, errs) = getMessages pst dflags
376 in
377 do
378 -- Just because we got a `POk`, it doesn't mean there
379 -- weren't errors! To clarify, the GHC parser
380 -- distinguishes between fatal and non-fatal
381 -- errors. Non-fatal errors are the sort that don't
382 -- prevent parsing from continuing (that is, a parse
383 -- tree can still be produced despite the error so that
384 -- further errors/warnings can be collected). Fatal
385 -- errors are those from which a parse tree just can't
386 -- be produced.
387 unless (null errs) $
388 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
390 -- Ok, we got here. It's safe to continue.
391 let (errs, parsed) = preprocessor rdr_module
392 unless (null errs) $ throwE $ diagFromStrings "parser" errs
393 ms <- getModSummaryFromBuffer filename contents dflags parsed
394 let pm =
395 ParsedModule {
396 pm_mod_summary = ms
397 , pm_parsed_source = parsed
398 , pm_extra_src_files=[] -- src imports not allowed
399 , pm_annotations = hpm_annotations
400 }
401 warnings = diagFromErrMsgs "parser" dflags warns
402 pure (warnings, pm)
405-- | This reads the pragma information directly from the provided buffer.
406parsePragmasIntoDynFlags
407 :: GhcMonad m
408 => FilePath
409 -> SB.StringBuffer
410 -> m (Either [FileDiagnostic] DynFlags)
411parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
412 dflags0 <- getSessionDynFlags
413 let opts = Hdr.getOptions dflags0 contents fp
414 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
415 return dflags
417-- | Run something in a Ghc monad and catch the errors (SourceErrors and
418-- compiler-internal exceptions like Panic or InstallationError).
419catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
420catchSrcErrors fromWhere ghcM = do
421 dflags <- getDynFlags
422 handleGhcException (ghcExceptionToDiagnostics dflags) $
423 handleSourceError (sourceErrorToDiagnostics dflags) $
424 Right <$> ghcM
425 where
426 ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags
427 sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages