@@ -0,0 +1,506 @@
1+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RankNTypes #-}
6+
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.
9+module Development.IDE.Functions.Compile
10+ ( CompileOpts(..)
11+ , PackageState(..)
12+ , GhcModule(..)
13+ , TcModuleResult(..)
14+ , LoadPackageResult(..)
15+ , getGhcDynFlags
16+ , compileModule
17+ , getSrcSpanInfos
18+ , parseModule
19+ , typecheckModule
20+ , loadPackage
21+ , computePackageDeps
22+ , generatePackageState
23+ ) where
24+
25+import Development.IDE.Functions.Warnings
26+import Development.IDE.Types.Diagnostics
27+import qualified Development.IDE.Functions.FindImports as FindImports
28+import Development.IDE.Functions.GHCError
29+import Development.IDE.Functions.SpanInfo
30+import Development.IDE.UtilGHC
31+
32+import "ghc-lib" GHC hiding (parseModule, typecheckModule)
33+import qualified "ghc-lib-parser" Parser
34+import "ghc-lib-parser" Lexer
35+import "ghc-lib-parser" Bag
36+
37+import qualified "ghc-lib" GHC
38+import "ghc-lib-parser" Panic
39+import "ghc-lib-parser" GhcMonad
40+import "ghc-lib" GhcPlugins as GHC hiding (PackageState, fst3, (<>))
41+import qualified "ghc-lib" HeaderInfo as Hdr
42+import "ghc-lib" MkIface
43+import "ghc-lib-parser" NameCache
44+import "ghc-lib-parser" StringBuffer as SB
45+import "ghc-lib" TidyPgm
46+import "ghc-lib-parser" InstEnv
47+import "ghc-lib-parser" FamInstEnv
48+
49+import Control.DeepSeq
50+import Control.Exception as E
51+import Control.Monad
52+import qualified Control.Monad.Trans.Except as Ex
53+import Data.IORef
54+import Data.List.Extra
55+import Data.Maybe
56+import Data.Tuple.Extra
57+import qualified Data.Map.Strict as Map
58+import Data.Time
59+import Development.IDE.Types.SpanInfo
60+import GHC.Generics (Generic)
61+import System.FilePath
62+
63+-- TODO (MK) Move to a separate Options module
64+data CompileOpts = CompileOpts
65+ { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)
66+ , optRunGhcSession :: forall a. Maybe ParsedModule -> PackageState -> Ghc a -> IO a
67+ -- ^ Setup a GHC session using a given package state. If a `ParsedModule` is supplied,
68+ -- the import path should be setup for that module.
69+ , optWriteIface :: Bool
70+
71+ , optMbPackageName :: Maybe String
72+
73+ , optPackageDbs :: [FilePath]
74+ , optHideAllPkgs :: Bool
75+ , optPackageImports :: [(String, [(String, String)])]
76+
77+ , optThreads :: Int
78+ , optShakeProfiling :: Maybe FilePath
79+ }
80+
81+-- | 'CoreModule' together with some additional information required for the
82+-- conversion to DAML-LF.
83+data GhcModule = GhcModule
84+ { gmPath :: Maybe FilePath
85+ , gmCore :: CoreModule
86+ }
87+ deriving (Generic, Show)
88+
89+instance NFData GhcModule
90+
91+-- | Contains the typechecked module and the OrigNameCache entry for
92+-- that module.
93+data TcModuleResult = TcModuleResult
94+ { tmrModule :: TypecheckedModule
95+ , tmrModInfo :: HomeModInfo
96+ , tmrOccEnvName :: OccEnv Name
97+ }
98+
99+-- | Contains the result of loading an interface. In particular the delta to the name cache.
100+data LoadPackageResult = LoadPackageResult
101+ { lprInstalledUnitId :: InstalledUnitId
102+ , lprModuleEnv :: ModuleEnv (OccEnv Name)
103+ , lprEps :: ExternalPackageState
104+ }
105+
106+-- | Get source span info, used for e.g. AtPoint and Goto Definition.
107+getSrcSpanInfos
108+ :: CompileOpts
109+ -> ParsedModule
110+ -> PackageState
111+ -> [(Located ModuleName, Maybe FilePath)]
112+ -> TcModuleResult
113+ -> IO [SpanInfo]
114+getSrcSpanInfos opt mod packageState imports tc =
115+ runGhcSession opt (Just mod) packageState
116+ . getSpanInfo imports
117+ $ tmrModule tc
118+
119+
120+-- | Given a string buffer, return a pre-processed @ParsedModule@.
121+parseModule
122+ :: CompileOpts
123+ -> PackageState
124+ -> FilePath
125+ -> (UTCTime, SB.StringBuffer)
126+ -> IO ([Diagnostic], Maybe ParsedModule)
127+parseModule opt@CompileOpts{..} packageState file =
128+ fmap (either (, Nothing) (second Just)) . Ex.runExceptT .
129+ -- We need packages since imports fail to resolve otherwise.
130+ runGhcSessionExcept opt Nothing packageState . parseFileContents optPreprocessor file
131+
132+computePackageDeps ::
133+ CompileOpts -> PackageState -> InstalledUnitId -> IO (Either [Diagnostic] [InstalledUnitId])
134+computePackageDeps opts packageState iuid =
135+ Ex.runExceptT $
136+ runGhcSessionExcept opts Nothing packageState $
137+ catchSrcErrors $ do
138+ dflags <- hsc_dflags <$> getSession
139+ liftIO $ depends <$> getPackage dflags iuid
140+
141+getPackage :: DynFlags -> InstalledUnitId -> IO PackageConfig
142+getPackage dflags p =
143+ case lookupInstalledPackage dflags p of
144+ Nothing -> E.throwIO $ CmdLineError (missingPackageMsg p)
145+ Just pkg -> return pkg
146+ where
147+ missingPackageMsg p = showSDoc dflags $ text "unknown package:" <+> ppr p
148+
149+-- | Typecheck a single module using the supplied dependencies and packages.
150+typecheckModule
151+ :: CompileOpts
152+ -> ParsedModule
153+ -> PackageState
154+ -> UniqSupply
155+ -> [TcModuleResult]
156+ -> [LoadPackageResult]
157+ -> ParsedModule
158+ -> IO ([Diagnostic], Maybe TcModuleResult)
159+typecheckModule opt mod packageState uniqSupply deps pkgs pm =
160+ fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
161+ runGhcSessionExcept opt (Just mod) packageState $
162+ catchSrcErrors $ do
163+ setupEnv uniqSupply deps pkgs
164+ (warnings, tcm) <- withWarnings "Typechecker" $ \tweak ->
165+ GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}
166+ tcm2 <- mkTcModuleResult (WriteInterface $ optWriteIface opt) tcm
167+ return (warnings, tcm2)
168+
169+-- | Load a pkg and populate the name cache and external package state.
170+loadPackage ::
171+ CompileOpts
172+ -> PackageState
173+ -> UniqSupply
174+ -> [LoadPackageResult]
175+ -> InstalledUnitId
176+ -> IO (Either [Diagnostic] LoadPackageResult)
177+loadPackage opt packageState us lps p =
178+ Ex.runExceptT $
179+ runGhcSessionExcept opt Nothing packageState $
180+ catchSrcErrors $ do
181+ setupEnv us [] lps
182+ dflags <- hsc_dflags <$> getSession
183+ exposedMods <- liftIO $ exposedModules <$> getPackage dflags p
184+ let mods =
185+ [ Module (DefiniteUnitId (DefUnitId p)) mod
186+ | (mod, _mbParent) <- exposedMods
187+ ]
188+ forM_ mods $ \mod -> GHC.getModuleInfo mod
189+ -- this populates the namecache and external package state
190+ session <- getSession
191+ modEnv <- nsNames <$> liftIO (readIORef $ hsc_NC session)
192+ eps <- liftIO (readIORef $ hsc_EPS session)
193+ pure $ LoadPackageResult p modEnv eps
194+
195+-- | Compile a single type-checked module to a 'CoreModule' value, or
196+-- provide errors.
197+compileModule
198+ :: CompileOpts
199+ -> ParsedModule
200+ -> PackageState
201+ -> UniqSupply
202+ -> [TcModuleResult]
203+ -> [LoadPackageResult]
204+ -> TcModuleResult
205+ -> IO ([Diagnostic], Maybe GhcModule)
206+compileModule opt mod packageState uniqSupply deps pkgs tmr =
207+ fmap (either (, Nothing) (second Just)) $ Ex.runExceptT $
208+ runGhcSessionExcept opt (Just mod) packageState $
209+ catchSrcErrors $ do
210+ setupEnv uniqSupply (deps ++ [tmr]) pkgs
211+
212+ let tm = tmrModule tmr
213+ session <- getSession
214+ (warnings,desugar) <- withWarnings "Desugarer" $ \tweak -> do
215+ let pm = tm_parsed_module tm
216+ let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
217+ let tm' = tm{tm_parsed_module = pm'}
218+ removeTypeableInfo . GHC.dm_core_module <$> GHC.desugarModule tm'
219+
220+ -- give variables unique OccNames
221+ (tidy, details) <- liftIO $ tidyProgram session desugar
222+
223+ let path = ml_hs_file $ ms_location $ pm_mod_summary $ tm_parsed_module tm
224+ let core = CoreModule
225+ (cg_module tidy)
226+ (md_types details)
227+ (cg_binds tidy)
228+ (mg_safe_haskell desugar)
229+
230+ return (warnings, GhcModule path core)
231+
232+-- | Evaluate a GHC session using a new environment constructed with
233+-- the supplied options.
234+runGhcSessionExcept
235+ :: CompileOpts
236+ -> Maybe ParsedModule
237+ -> PackageState
238+ -> Ex.ExceptT e Ghc a
239+ -> Ex.ExceptT e IO a
240+runGhcSessionExcept opts mbMod pkg m =
241+ Ex.ExceptT $ runGhcSession opts mbMod pkg $ Ex.runExceptT m
242+
243+
244+getGhcDynFlags :: CompileOpts -> ParsedModule -> PackageState -> IO DynFlags
245+getGhcDynFlags opts mod pkg = runGhcSession opts (Just mod) pkg getSessionDynFlags
246+
247+-- | Evaluate a GHC session using a new environment constructed with
248+-- the supplied options.
249+runGhcSession
250+ :: CompileOpts
251+ -> Maybe ParsedModule
252+ -> PackageState
253+ -> Ghc a
254+ -> IO a
255+runGhcSession CompileOpts{..} = optRunGhcSession
256+
257+-- When we make a fresh GHC environment, the OrigNameCache comes already partially
258+-- populated. So to be safe, we simply extend this one.
259+mkNameCache :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m NameCache
260+mkNameCache uniqSupply tms pkgs = do
261+ session <- getSession
262+ onc <- nsNames <$> liftIO (readIORef $ hsc_NC session)
263+ return NameCache
264+ { nsUniqs = uniqSupply
265+ , nsNames = extendOrigNameCache' onc tms pkgs
266+ }
267+
268+-- | Extend the name cache with the names from the typechecked home modules and the loaded packages.
269+-- If we have two environments containing the same module we take the later one. We do this because
270+-- the name cache comes prepopulated with modules from daml-prim and we overwrite those with our own
271+-- daml-prim package.
272+extendOrigNameCache' :: OrigNameCache -> [TcModuleResult] -> [LoadPackageResult] -> OrigNameCache
273+extendOrigNameCache' onc tms pkgs = foldl (plusModuleEnv_C (\_x y -> y)) onc modEnvs
274+ where
275+ modEnvs =
276+ mkModuleEnv
277+ [(ms_mod $ tcModSummary $ tmrModule tm, tmrOccEnvName tm) | tm <- tms] :
278+ [lprModuleEnv lm | lm <- pkgs]
279+
280+newtype WriteInterface = WriteInterface Bool
281+
282+mkTcModuleResult
283+ :: GhcMonad m
284+ => WriteInterface
285+ -> TypecheckedModule
286+ -> m TcModuleResult
287+mkTcModuleResult (WriteInterface writeIface) tcm = do
288+ session <- getSession
289+ nc <- liftIO $ readIORef (hsc_NC session)
290+ (iface,_) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
291+ when writeIface $
292+ liftIO $ do
293+ writeIfaceFile (hsc_dflags session) (replaceExtension (file tcm) ".hi") iface
294+ let mod_info = HomeModInfo iface details Nothing
295+ origNc = nsNames nc
296+ case lookupModuleEnv origNc (tcmModule tcm) of
297+ Nothing -> panic err
298+ Just occ -> return $ TcModuleResult tcm mod_info occ
299+ where
300+ file = ms_hspp_file . tcModSummary
301+ tcmModule = ms_mod . tcModSummary
302+ (tcGblEnv, details) = tm_internals_ tcm
303+ err = "Internal error : module not found in NameCache :" <>
304+ moduleNameString (moduleName $ tcmModule tcm)
305+
306+tcModSummary :: TypecheckedModule -> ModSummary
307+tcModSummary = pm_mod_summary . tm_parsed_module
308+
309+-- | Setup the environment that GHC needs according to our
310+-- best understanding (!)
311+setupEnv :: GhcMonad m => UniqSupply -> [TcModuleResult] -> [LoadPackageResult] -> m ()
312+setupEnv uniqSupply tms lps = do
313+ session <- getSession
314+
315+ let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
316+
317+ -- set the target and module graph in the session
318+ let graph = mkModuleGraph mss
319+ setSession session { hsc_mod_graph = graph }
320+
321+ -- Make modules available for others that import them,
322+ -- by putting them in the finder cache.
323+ let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
324+ ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
325+ liftIO $ modifyIORef (hsc_FC session) $ \fc ->
326+ foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc
327+ $ zip ims ifrs
328+
329+ -- construct a new NameCache
330+ nc' <- mkNameCache uniqSupply tms lps
331+ -- update the name cache
332+ liftIO $ modifyIORef (hsc_NC session) $ const nc'
333+ -- update the external package state
334+ liftIO $ modifyIORef (hsc_EPS session) (updateEps lps)
335+ -- load dependent modules, which must be in topological order.
336+ mapM_ loadModuleHome tms
337+
338+-- | Update the external package state given the loaded package results.
339+updateEps :: [LoadPackageResult] -> ExternalPackageState -> ExternalPackageState
340+updateEps lps eps =
341+ eps
342+ { eps_inst_env = newInstEnv
343+ , eps_PIT = newPIT
344+ , eps_PTE = newPTE
345+ , eps_rule_base = newRuleBase
346+ , eps_complete_matches = newCompleteMatches
347+ , eps_fam_inst_env = newFamInst
348+ , eps_ann_env = newAnnEnv
349+ , eps_mod_fam_inst_env = newModFamInstEnv
350+ }
351+ where
352+ (newInstEnv, (newPIT, (newPTE, (newRuleBase, (newCompleteMatches, (newFamInst, (newAnnEnv, newModFamInstEnv))))))) =
353+ foldl
354+ (\(instEnv, (pit, (pte, (ruleBase, (completeMatches, (famInst, (annEnv, modFamInstEnv))))))) ->
355+ (instEnv `extendInstEnvList0`) ***
356+ (pit `plusModuleEnv`) ***
357+ (pte `plusTypeEnv`) ***
358+ (ruleBase `unionRuleBase`) ***
359+ (completeMatches `extendCompleteMatchMap`) ***
360+ (famInst `extendFamInstEnvList`) ***
361+ (annEnv `plusAnnEnv`) *** (modFamInstEnv `plusModuleEnv`))
362+ ( emptyInstEnv
363+ , ( emptyPackageIfaceTable
364+ , ( emptyTypeEnv
365+ , ( emptyRuleBase
366+ , (emptyUFM, (emptyFamInstEnv, (emptyAnnEnv, emptyModuleEnv)))))))
367+ [ ( instEnvElts $ eps_inst_env e
368+ , ( eps_PIT e
369+ , ( eps_PTE e
370+ , ( eps_rule_base e
371+ , ( concat $ eltsUFM $ eps_complete_matches e
372+ , ( famInstEnvElts $ eps_fam_inst_env e
373+ , (eps_ann_env e, eps_mod_fam_inst_env e)))))))
374+ | p <- lps
375+ , let e = lprEps p
376+ ]
377+
378+ -- TODO (drsk): This is necessary because the EPS that we store include the results of
379+ -- previously loaded packages and we end up adding instances several times to the environment.
380+ -- It would be better to have pure delta stored in the LoadPackageResult, such that it
381+ -- contains only identities/instances/names coming from that specific loaded package, but I
382+ -- failed so far in computing the correct delta.
383+ extendInstEnvList0 instEnv0 clsInsts =
384+ extendInstEnvList emptyInstEnv $
385+ nubOrdOn is_dfun_name $ instEnvElts instEnv0 ++ clsInsts
386+
387+-- | Load a module, quickly. Input doesn't need to be desugared.
388+-- A module must be loaded before dependent modules can be typechecked.
389+-- This variant of loadModuleHome will *never* cause recompilation, it just
390+-- modifies the session.
391+loadModuleHome
392+ :: (GhcMonad m)
393+ => TcModuleResult
394+ -> m ()
395+loadModuleHome tmr = modifySession $ \e ->
396+ e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
397+ where
398+ ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
399+ mod_info = tmrModInfo tmr
400+ mod = ms_mod_name ms
401+
402+-- | Produce a module summary from a StringBuffer.
403+getModSummaryFromBuffer
404+ :: GhcMonad m
405+ => FilePath
406+ -> (SB.StringBuffer, UTCTime)
407+ -> DynFlags
408+ -> GHC.ParsedSource
409+ -> Ex.ExceptT [Diagnostic] m ModSummary
410+getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do
411+ (modName, imports) <- FindImports.getImportsParsed dflags parsed
412+
413+ let modLoc = ModLocation
414+ { ml_hs_file = Just fp
415+ , ml_hi_file = replaceExtension fp "hi"
416+ , ml_obj_file = replaceExtension fp "o"
417+ , ml_hie_file = replaceExtension fp "hie"
418+ -- This does not consider the dflags configuration
419+ -- (-osuf and -hisuf, object and hi dir.s).
420+ -- However, we anyway don't want to generate them.
421+ }
422+ InstalledUnitId unitId = thisInstalledUnitId dflags
423+ return $ ModSummary
424+ { ms_mod = mkModule (fsToUnitId unitId) modName
425+ , ms_location = modLoc
426+ , ms_hs_date = fileDate
427+ , ms_textual_imps = imports
428+ , ms_hspp_file = fp
429+ , ms_hspp_opts = dflags
430+ , ms_hspp_buf = Just contents
431+
432+ -- defaults:
433+ , ms_hsc_src = HsSrcFile
434+ , ms_obj_date = Nothing
435+ , ms_iface_date = Nothing
436+ , ms_hie_date = Nothing
437+ , ms_srcimps = [] -- source imports are not allowed
438+ , ms_parsed_mod = Nothing
439+ }
440+
441+-- | Given a buffer, flags, file path and module summary, produce a
442+-- parsed module (or errors) and any parse warnings.
443+parseFileContents
444+ :: GhcMonad m
445+ => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))
446+ -> FilePath -- ^ the filename (for source locations)
447+ -> (UTCTime, SB.StringBuffer) -- ^ Haskell module source text (full Unicode is supported)
448+ -> Ex.ExceptT [Diagnostic] m ([Diagnostic], ParsedModule)
449+parseFileContents preprocessor filename (time, contents) = do
450+ let loc = mkRealSrcLoc (mkFastString filename) 1 1
451+ dflags <- parsePragmasIntoDynFlags filename contents
452+ case unP Parser.parseModule (mkPState dflags contents loc) of
453+ PFailed s ->
454+ Ex.throwE $ toDiagnostics dflags $ snd $ getMessages s dflags
455+ POk pst rdr_module ->
456+ let hpm_annotations =
457+ (Map.fromListWith (++) $ annotations pst,
458+ Map.fromList ((noSrcSpan,comment_q pst)
459+ :annotations_comments pst))
460+ (warns,_) = getMessages pst dflags
461+ in
462+ do
463+ let (errs, parsed) = preprocessor rdr_module
464+ unless (null errs) $ Ex.throwE $ mkErrors dflags errs
465+ ms <- getModSummaryFromBuffer filename (contents, time) dflags parsed
466+ let pm =
467+ ParsedModule {
468+ pm_mod_summary = ms
469+ , pm_parsed_source = parsed
470+ , pm_extra_src_files=[] -- src imports not allowed
471+ , pm_annotations = hpm_annotations
472+ }
473+ warnings = mapMaybe (mkDiag dflags "Parser") $ bagToList warns
474+ pure (warnings, pm)
475+
476+
477+-- | This reads the pragma information directly from the provided buffer.
478+parsePragmasIntoDynFlags
479+ :: GhcMonad m
480+ => FilePath
481+ -> SB.StringBuffer
482+ -> Ex.ExceptT [Diagnostic] m DynFlags
483+parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do
484+ dflags0 <- getSessionDynFlags
485+ let opts = Hdr.getOptions dflags0 contents fp
486+ (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
487+ return dflags
488+
489+generatePackageState :: [FilePath] -> Bool -> [(String, [(String, String)])] -> IO PackageState
490+generatePackageState paths hideAllPkgs pkgImports = do
491+ let dflags = setPackageImports hideAllPkgs pkgImports $ setPackageDbs paths (defaultDynFlags fakeSettings fakeLlvmConfig)
492+ (newDynFlags, _) <- initPackages dflags
493+ pure $ PackageState (pkgDatabase newDynFlags) (pkgState newDynFlags) (thisUnitIdInsts_ newDynFlags)
494+
495+-- | Run something in a Ghc monad and catch the errors (SourceErrors and
496+-- compiler-internal exceptions like Panic or InstallationError).
497+catchSrcErrors :: GhcMonad m => m a -> Ex.ExceptT [Diagnostic] m a
498+catchSrcErrors ghcM = do
499+ dflags <- getDynFlags
500+ Ex.ExceptT $
501+ handleGhcException (ghcExceptionToDiagnostics dflags) $
502+ handleSourceError (sourceErrorToDiagnostics dflags) $
503+ Right <$> ghcM
504+ where
505+ ghcExceptionToDiagnostics dflags = return . Left . mkErrorsGhcException dflags
506+ sourceErrorToDiagnostics dflags = return . Left . toDiagnostics dflags . srcErrorMessages