git.iko.soy/ghcide
on a58751e help sign in
ghcide/src/Development/IDE/Core/Compile.hs
313 lines 12 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.Core.Preprocessor
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 qualified GHC.LanguageExtensions.Type as GHC
26import Development.IDE.Types.Options
27import Development.IDE.Types.Location
29import GHC hiding (parseModule, typecheckModule)
30import qualified Parser
31import Lexer
32import ErrUtils
34import qualified GHC
35import GhcMonad
36import GhcPlugins as GHC hiding (fst3, (<>))
37import qualified HeaderInfo as Hdr
38import MkIface
39import StringBuffer as SB
40import TidyPgm
42import Control.Monad.Extra
43import Control.Monad.Except
44import Control.Monad.Trans.Except
45import Data.Function
46import Data.Ord
47import qualified Data.Text as T
48import Data.IORef
49import Data.List.Extra
50import Data.Maybe
51import Data.Tuple.Extra
52import qualified Data.Map.Strict as Map
53import System.FilePath
56-- | Given a string buffer, return a pre-processed @ParsedModule@.
57parseModule
58 :: IdeOptions
59 -> HscEnv
60 -> FilePath
61 -> Maybe SB.StringBuffer
62 -> IO ([FileDiagnostic], Maybe ParsedModule)
63parseModule IdeOptions{..} env file =
64 fmap (either (, Nothing) (second Just)) .
65 -- We need packages since imports fail to resolve otherwise.
66 runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
69-- | Given a package identifier, what packages does it depend on
70computePackageDeps
71 :: HscEnv
72 -> InstalledUnitId
73 -> IO (Either [FileDiagnostic] [InstalledUnitId])
74computePackageDeps env pkg = do
75 let dflags = hsc_dflags env
76 case lookupInstalledPackage dflags pkg of
77 Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
78 T.pack $ "unknown package: " ++ show pkg]
79 Just pkgInfo -> return $ Right $ depends pkgInfo
82-- | Typecheck a single module using the supplied dependencies and packages.
83typecheckModule
84 :: HscEnv
85 -> [TcModuleResult]
86 -> ParsedModule
87 -> IO ([FileDiagnostic], Maybe TcModuleResult)
88typecheckModule packageState deps pm =
89 fmap (either (, Nothing) (second Just)) $
90 runGhcEnv packageState $
91 catchSrcErrors "typecheck" $ do
92 setupEnv deps
93 (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
94 GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
95 tcm2 <- mkTcModuleResult tcm
96 return (warnings, tcm2)
98-- | Compile a single type-checked module to a 'CoreModule' value, or
99-- provide errors.
100compileModule
101 :: HscEnv
102 -> [TcModuleResult]
103 -> TcModuleResult
104 -> IO ([FileDiagnostic], Maybe CoreModule)
105compileModule packageState deps tmr =
106 fmap (either (, Nothing) (second Just)) $
107 runGhcEnv packageState $
108 catchSrcErrors "compile" $ do
109 setupEnv (deps ++ [tmr])
111 let tm = tmrModule tmr
112 session <- getSession
113 (warnings,desugar) <- withWarnings "compile" $ \tweak -> do
114 let pm = tm_parsed_module tm
115 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
116 let tm' = tm{tm_parsed_module = pm'}
117 GHC.dm_core_module <$> GHC.desugarModule tm'
119 -- give variables unique OccNames
120 (tidy, details) <- liftIO $ tidyProgram session desugar
122 let core = CoreModule
123 (cg_module tidy)
124 (md_types details)
125 (cg_binds tidy)
126 (mg_safe_haskell desugar)
128 return (warnings, core)
131addRelativeImport :: ParsedModule -> DynFlags -> DynFlags
132addRelativeImport modu dflags = dflags
133 {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}
135mkTcModuleResult
136 :: GhcMonad m
137 => TypecheckedModule
138 -> m TcModuleResult
139mkTcModuleResult tcm = do
140 session <- getSession
141 (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
142 let mod_info = HomeModInfo iface details Nothing
143 return $ TcModuleResult tcm mod_info
144 where
145 (tcGblEnv, details) = tm_internals_ tcm
147-- | Setup the environment that GHC needs according to our
148-- best understanding (!)
149setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
150setupEnv tmsIn = do
151 -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
152 -- takes precedence, so put the .hs-boot file earlier in the list
153 let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
154 tms = sortBy (compare `on` Down . isSourceFile) tmsIn
156 session <- getSession
158 let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
160 -- set the target and module graph in the session
161 let graph = mkModuleGraph mss
162 setSession session { hsc_mod_graph = graph }
164 -- Make modules available for others that import them,
165 -- by putting them in the finder cache.
166 let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
167 ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
168 liftIO $ modifyIORef (hsc_FC session) $ \fc ->
169 foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
170 $ zip ims ifrs
172 -- load dependent modules, which must be in topological order.
173 mapM_ loadModuleHome tms
176-- | Load a module, quickly. Input doesn't need to be desugared.
177-- A module must be loaded before dependent modules can be typechecked.
178-- This variant of loadModuleHome will *never* cause recompilation, it just
179-- modifies the session.
180loadModuleHome
181 :: (GhcMonad m)
182 => TcModuleResult
183 -> m ()
184loadModuleHome tmr = modifySession $ \e ->
185 e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
186 where
187 ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
188 mod_info = tmrModInfo tmr
189 mod = ms_mod_name ms
193-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
194-- name and its imports.
195getImportsParsed :: DynFlags ->
196 GHC.ParsedSource ->
197 Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
198getImportsParsed dflags (L loc parsed) = do
199 let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
201 -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
202 -- but we want to avoid parsing the module twice
203 let implicit_prelude = xopt GHC.ImplicitPrelude dflags
204 implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
206 -- filter out imports that come from packages
207 return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
208 | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
209 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
210 ])
213-- | Produce a module summary from a StringBuffer.
214getModSummaryFromBuffer
215 :: GhcMonad m
216 => FilePath
217 -> SB.StringBuffer
218 -> DynFlags
219 -> GHC.ParsedSource
220 -> ExceptT [FileDiagnostic] m ModSummary
221getModSummaryFromBuffer fp contents dflags parsed = do
222 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
224 let modLoc = ModLocation
225 { ml_hs_file = Just fp
226 , ml_hi_file = derivedFile "hi"
227 , ml_obj_file = derivedFile "o"
228#ifndef GHC_STABLE
229 , ml_hie_file = derivedFile "hie"
230#endif
231 -- This does not consider the dflags configuration
232 -- (-osuf and -hisuf, object and hi dir.s).
233 -- However, we anyway don't want to generate them.
234 }
235 InstalledUnitId unitId = thisInstalledUnitId dflags
236 return $ ModSummary
237 { ms_mod = mkModule (fsToUnitId unitId) modName
238 , ms_location = modLoc
239 , ms_hs_date = error "Rules should not depend on ms_hs_date"
240 -- When we are working with a virtual file we do not have a file date.
241 -- To avoid silent issues where something is not processed because the date
242 -- has not changed, we make sure that things blow up if they depend on the
243 -- date.
244 , ms_textual_imps = [imp | (False, imp) <- imports]
245 , ms_hspp_file = fp
246 , ms_hspp_opts = dflags
247 , ms_hspp_buf = Just contents
249 -- defaults:
250 , ms_hsc_src = sourceType
251 , ms_obj_date = Nothing
252 , ms_iface_date = Nothing
253#ifndef GHC_STABLE
254 , ms_hie_date = Nothing
255#endif
256 , ms_srcimps = [imp | (True, imp) <- imports]
257 , ms_parsed_mod = Nothing
258 }
259 where
260 (sourceType, derivedFile) =
261 let (stem, ext) = splitExtension fp in
262 if "-boot" `isSuffixOf` ext
263 then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
264 else (HsSrcFile , \newExt -> stem <.> newExt)
267-- | Given a buffer, flags, file path and module summary, produce a
268-- parsed module (or errors) and any parse warnings.
269parseFileContents
270 :: GhcMonad m
271 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
272 -> FilePath -- ^ the filename (for source locations)
273 -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
274 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
275parseFileContents customPreprocessor filename mbContents = do
276 (contents, dflags) <- preprocessor filename mbContents
277 let loc = mkRealSrcLoc (mkFastString filename) 1 1
278 case unP Parser.parseModule (mkPState dflags contents loc) of
279 PFailed _ locErr msgErr ->
280 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
281 POk pst rdr_module ->
282 let hpm_annotations =
283 (Map.fromListWith (++) $ annotations pst,
284 Map.fromList ((noSrcSpan,comment_q pst)
285 :annotations_comments pst))
286 (warns, errs) = getMessages pst dflags
287 in
288 do
289 -- Just because we got a `POk`, it doesn't mean there
290 -- weren't errors! To clarify, the GHC parser
291 -- distinguishes between fatal and non-fatal
292 -- errors. Non-fatal errors are the sort that don't
293 -- prevent parsing from continuing (that is, a parse
294 -- tree can still be produced despite the error so that
295 -- further errors/warnings can be collected). Fatal
296 -- errors are those from which a parse tree just can't
297 -- be produced.
298 unless (null errs) $
299 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
301 -- Ok, we got here. It's safe to continue.
302 let (errs, parsed) = customPreprocessor rdr_module
303 unless (null errs) $ throwE $ diagFromStrings "parser" errs
304 ms <- getModSummaryFromBuffer filename contents dflags parsed
305 let pm =
306 ParsedModule {
307 pm_mod_summary = ms
308 , pm_parsed_source = parsed
309 , pm_extra_src_files=[] -- src imports not allowed
310 , pm_annotations = hpm_annotations
311 }
312 warnings = diagFromErrMsgs "parser" dflags warns
313 pure (warnings, pm)