Support for abi-depends for computing shadowing.
[ghc.git] / compiler / backpack / DriverBkp.hs
1 {-# LANGUAGE NondecreasingIndentation #-}
2 {-# LANGUAGE TypeSynonymInstances #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE CPP #-}
5
6 -- | This is the driver for the 'ghc --backpack' mode, which
7 -- is a reimplementation of the "package manager" bits of
8 -- Backpack directly in GHC. The basic method of operation
9 -- is to compile packages and then directly insert them into
10 -- GHC's in memory database.
11 --
12 -- The compilation products of this mode aren't really suitable
13 -- for Cabal, because GHC makes up component IDs for the things
14 -- it builds and doesn't serialize out the database contents.
15 -- But it's still handy for constructing tests.
16
17 module DriverBkp (doBackpack) where
18
19 #include "HsVersions.h"
20
21 -- In a separate module because it hooks into the parser.
22 import BkpSyn
23
24 import GHC hiding (Failed, Succeeded)
25 import Packages
26 import Parser
27 import Lexer
28 import GhcMonad
29 import DynFlags
30 import TcRnMonad
31 import TcRnDriver
32 import Module
33 import HscTypes
34 import StringBuffer
35 import FastString
36 import ErrUtils
37 import SrcLoc
38 import HscMain
39 import UniqFM
40 import UniqDFM
41 import Outputable
42 import Maybes
43 import HeaderInfo
44 import MkIface
45 import GhcMake
46 import UniqDSet
47 import PrelNames
48 import BasicTypes hiding (SuccessFlag(..))
49 import Finder
50 import Util
51
52 import qualified GHC.LanguageExtensions as LangExt
53
54 import Data.List
55 import System.Exit
56 import Control.Monad
57 import System.FilePath
58 import Data.Version
59
60 -- for the unification
61 import Data.IORef
62 import Data.Map (Map)
63 import qualified Data.Map as Map
64
65 -- | Entry point to compile a Backpack file.
66 doBackpack :: FilePath -> Ghc ()
67 doBackpack src_filename = do
68 -- Apply options from file to dflags
69 dflags0 <- getDynFlags
70 let dflags1 = dflags0
71 src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
72 (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
73 modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
74 -- Cribbed from: preprocessFile / DriverPipeline
75 liftIO $ checkProcessArgsResult dflags unhandled_flags
76 liftIO $ handleFlagWarnings dflags warns
77 -- TODO: Preprocessing not implemented
78
79 buf <- liftIO $ hGetStringBuffer src_filename
80 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
81 case unP parseBackpack (mkPState dflags buf loc) of
82 PFailed span err -> do
83 liftIO $ throwOneError (mkPlainErrMsg dflags span err)
84 POk _ pkgname_bkp -> do
85 -- OK, so we have an LHsUnit PackageName, but we want an
86 -- LHsUnit HsComponentId. So let's rename it.
87 let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
88 initBkpM src_filename bkp $
89 forM_ (zip [1..] bkp) $ \(i, lunit) -> do
90 let comp_name = unLoc (hsunitName (unLoc lunit))
91 msgTopPackage (i,length bkp) comp_name
92 innerBkpM $ do
93 let (cid, insts) = computeUnitId lunit
94 if null insts
95 then if cid == ComponentId (fsLit "main")
96 then compileExe lunit
97 else compileUnit cid []
98 else typecheckUnit cid insts
99
100 computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
101 computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
102 where
103 cid = hsComponentId (unLoc (hsunitName unit))
104 reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
105 get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
106 get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
107 get_reqs (IncludeD (IncludeDecl (L _ hsuid) _)) =
108 unitIdFreeHoles (convertHsUnitId hsuid)
109
110 -- | Tiny enum for all types of Backpack operations we may do.
111 data SessionType = ExeSession | TcSession | CompSession
112 deriving (Eq)
113
114 -- | Create a temporary Session to do some sort of type checking or
115 -- compilation.
116 withBkpSession :: ComponentId
117 -> [(ModuleName, Module)]
118 -> [(UnitId, ModRenaming)]
119 -> SessionType -- what kind of session are we doing
120 -> BkpM a -- actual action to run
121 -> BkpM a
122 withBkpSession cid insts deps session_type do_this = do
123 dflags <- getDynFlags
124 let (ComponentId cid_fs) = cid
125 is_primary = False
126 uid_str = unpackFS (hashUnitId cid insts)
127 cid_str = unpackFS cid_fs
128 -- There are multiple units in a single Backpack file, so we
129 -- need to separate out the results in those cases. Right now,
130 -- we follow this hierarchy:
131 -- $outputdir/$compid --> typecheck results
132 -- $outputdir/$compid/$unitid --> compile results
133 key_base p | Just f <- p dflags = f
134 | otherwise = "."
135 sub_comp p | is_primary = p
136 | otherwise = p </> cid_str
137 outdir p | CompSession <- session_type
138 -- Special case when package is definite
139 , not (null insts) = sub_comp (key_base p) </> uid_str
140 | otherwise = sub_comp (key_base p)
141 withTempSession (overHscDynFlags (\dflags ->
142 -- If we're type-checking an indefinite package, we want to
143 -- turn on interface writing. However, if the user also
144 -- explicitly passed in `-fno-code`, we DON'T want to write
145 -- interfaces unless the user also asked for `-fwrite-interface`.
146 (case session_type of
147 -- Make sure to write interfaces when we are type-checking
148 -- indefinite packages.
149 TcSession | hscTarget dflags /= HscNothing
150 -> flip gopt_set Opt_WriteInterface
151 | otherwise -> id
152 CompSession -> id
153 ExeSession -> id) $
154 dflags {
155 hscTarget = case session_type of
156 TcSession -> HscNothing
157 _ -> hscTarget dflags,
158 thisUnitIdInsts_ = Just insts,
159 thisComponentId_ = Just cid,
160 thisInstalledUnitId =
161 case session_type of
162 TcSession -> newInstalledUnitId cid Nothing
163 -- No hash passed if no instances
164 _ | null insts -> newInstalledUnitId cid Nothing
165 | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
166 -- Setup all of the output directories according to our hierarchy
167 objectDir = Just (outdir objectDir),
168 hiDir = Just (outdir hiDir),
169 stubDir = Just (outdir stubDir),
170 -- Unset output-file for non exe builds
171 outputFile = if session_type == ExeSession
172 then outputFile dflags
173 else Nothing,
174 -- Synthesized the flags
175 packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
176 let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
177 in ExposePackage
178 (showSDoc dflags
179 (text "-unit-id" <+> ppr uid <+> ppr rn))
180 (UnitIdArg uid) rn) deps
181 } )) $ do
182 dflags <- getSessionDynFlags
183 -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
184 -- Calls initPackages
185 _ <- setSessionDynFlags dflags
186 do_this
187
188 withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
189 withBkpExeSession deps do_this = do
190 withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
191
192 getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
193 getSource cid = do
194 bkp_env <- getBkpEnv
195 case Map.lookup cid (bkp_table bkp_env) of
196 Nothing -> pprPanic "missing needed dependency" (ppr cid)
197 Just lunit -> return lunit
198
199 typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
200 typecheckUnit cid insts = do
201 lunit <- getSource cid
202 buildUnit TcSession cid insts lunit
203
204 compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
205 compileUnit cid insts = do
206 -- Let everyone know we're building this unit ID
207 msgUnitId (newUnitId cid insts)
208 lunit <- getSource cid
209 buildUnit CompSession cid insts lunit
210
211 -- Invariant: this NEVER returns InstalledUnitId
212 hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
213 hsunitDeps unit = concatMap get_dep (hsunitBody unit)
214 where
215 get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)]
216 where
217 go Nothing = ModRenaming True []
218 go (Just lrns) = ModRenaming False (map convRn lrns)
219 where
220 convRn (L _ (Renaming (L _ from) Nothing)) = (from, from)
221 convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
222 get_dep _ = []
223
224 buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
225 buildUnit session cid insts lunit = do
226 let deps_w_rns = hsunitDeps (unLoc lunit)
227 raw_deps = map fst deps_w_rns
228 dflags <- getDynFlags
229 -- The compilation dependencies are just the appropriately filled
230 -- in unit IDs which must be compiled before we can compile.
231 let hsubst = listToUFM insts
232 deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
233
234 -- Build dependencies OR make sure they make sense. BUT NOTE,
235 -- we can only check the ones that are fully filled; the rest
236 -- we have to defer until we've typechecked our local signature.
237 -- TODO: work this into GhcMake!!
238 forM_ (zip [1..] deps0) $ \(i, dep) ->
239 case session of
240 TcSession -> return ()
241 _ -> compileInclude (length deps0) (i, dep)
242
243 dflags <- getDynFlags
244 -- IMPROVE IT
245 let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
246
247 mb_old_eps <- case session of
248 TcSession -> fmap Just getEpsGhc
249 _ -> return Nothing
250
251 conf <- withBkpSession cid insts deps_w_rns session $ do
252
253 dflags <- getDynFlags
254 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
255 -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
256
257 msg <- mkBackpackMsg
258 ok <- load' LoadAllTargets (Just msg) mod_graph
259 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
260
261 let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
262 export_mod ms = (ms_mod_name ms, ms_mod ms)
263 -- Export everything!
264 mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]
265
266 -- Compile relevant only
267 hsc_env <- getSession
268 let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
269 linkables = map (expectJust "bkp link" . hm_linkable)
270 . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
271 $ home_mod_infos
272 getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
273 obj_files = concatMap getOfiles linkables
274
275 let compat_fs = (case cid of ComponentId fs -> fs)
276 cand_compat_pn = PackageName compat_fs
277 compat_pn = case session of
278 TcSession -> cand_compat_pn
279 _ | [] <- insts -> cand_compat_pn
280 | otherwise -> PackageName compat_fs
281
282 return InstalledPackageInfo {
283 -- Stub data
284 abiHash = "",
285 sourcePackageId = SourcePackageId compat_fs,
286 packageName = compat_pn,
287 packageVersion = makeVersion [0],
288 unitId = toInstalledUnitId (thisPackage dflags),
289 componentId = cid,
290 instantiatedWith = insts,
291 -- Slight inefficiency here haha
292 exposedModules = map (\(m,n) -> (m,Just n)) mods,
293 hiddenModules = [], -- TODO: doc only
294 depends = case session of
295 -- Technically, we should state that we depend
296 -- on all the indefinite libraries we used to
297 -- typecheck this. However, this field isn't
298 -- really used for anything, so we leave it
299 -- blank for now.
300 TcSession -> []
301 _ -> map (toInstalledUnitId . unwireUnitId dflags)
302 $ deps ++ [ moduleUnitId mod
303 | (_, mod) <- insts
304 , not (isHoleModule mod) ],
305 abiDepends = [],
306 ldOptions = case session of
307 TcSession -> []
308 _ -> obj_files,
309 importDirs = [ hi_dir ],
310 exposed = False,
311 indefinite = case session of
312 TcSession -> True
313 _ -> False,
314 -- nope
315 hsLibraries = [],
316 extraLibraries = [],
317 extraGHCiLibraries = [],
318 libraryDynDirs = [],
319 libraryDirs = [],
320 frameworks = [],
321 frameworkDirs = [],
322 ccOptions = [],
323 includes = [],
324 includeDirs = [],
325 haddockInterfaces = [],
326 haddockHTMLs = [],
327 trusted = False
328 }
329
330
331 addPackage conf
332 case mb_old_eps of
333 Just old_eps -> updateEpsGhc_ (const old_eps)
334 _ -> return ()
335
336 compileExe :: LHsUnit HsComponentId -> BkpM ()
337 compileExe lunit = do
338 msgUnitId mainUnitId
339 let deps_w_rns = hsunitDeps (unLoc lunit)
340 deps = map fst deps_w_rns
341 -- no renaming necessary
342 forM_ (zip [1..] deps) $ \(i, dep) ->
343 compileInclude (length deps) (i, dep)
344 withBkpExeSession deps_w_rns $ do
345 dflags <- getDynFlags
346 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
347 msg <- mkBackpackMsg
348 ok <- load' LoadAllTargets (Just msg) mod_graph
349 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
350
351 addPackage :: GhcMonad m => PackageConfig -> m ()
352 addPackage pkg = do
353 dflags0 <- GHC.getSessionDynFlags
354 case pkgDatabase dflags0 of
355 Nothing -> panic "addPackage: called too early"
356 Just pkgs -> do let dflags = dflags0 { pkgDatabase =
357 Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
358 _ <- GHC.setSessionDynFlags dflags
359 -- By this time, the global ref has probably already
360 -- been forced, in which case doing this isn't actually
361 -- going to do you any good.
362 -- dflags <- GHC.getSessionDynFlags
363 -- liftIO $ setUnsafeGlobalDynFlags dflags
364 return ()
365
366 -- Precondition: UnitId is NOT InstalledUnitId
367 compileInclude :: Int -> (Int, UnitId) -> BkpM ()
368 compileInclude n (i, uid) = do
369 hsc_env <- getSession
370 let dflags = hsc_dflags hsc_env
371 msgInclude (i, n) uid
372 -- Check if we've compiled it already
373 case lookupPackage dflags uid of
374 Nothing -> do
375 case splitUnitIdInsts uid of
376 (_, Just indef) ->
377 innerBkpM $ compileUnit (indefUnitIdComponentId indef)
378 (indefUnitIdInsts indef)
379 _ -> return ()
380 Just _ -> return ()
381
382 -- ----------------------------------------------------------------------------
383 -- Backpack monad
384
385 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
386 -- beyond the 'Session', c.f. 'BkpEnv'.
387 type BkpM = IOEnv BkpEnv
388
389 -- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
390 -- because we are going to update the 'HscEnv' as we go.
391 data BkpEnv
392 = BkpEnv {
393 -- | The session
394 bkp_session :: Session,
395 -- | The filename of the bkp file we're compiling
396 bkp_filename :: FilePath,
397 -- | Table of source units which we know how to compile
398 bkp_table :: Map ComponentId (LHsUnit HsComponentId),
399 -- | When a package we are compiling includes another package
400 -- which has not been compiled, we bump the level and compile
401 -- that.
402 bkp_level :: Int
403 }
404
405 -- Blah, to get rid of the default instance for IOEnv
406 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
407 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
408 getDynFlags = fmap hsc_dflags getSession
409
410 instance GhcMonad BkpM where
411 getSession = do
412 Session s <- fmap bkp_session getEnv
413 readMutVar s
414 setSession hsc_env = do
415 Session s <- fmap bkp_session getEnv
416 writeMutVar s hsc_env
417
418 -- | Get the current 'BkpEnv'.
419 getBkpEnv :: BkpM BkpEnv
420 getBkpEnv = getEnv
421
422 -- | Get the nesting level, when recursively compiling modules.
423 getBkpLevel :: BkpM Int
424 getBkpLevel = bkp_level `fmap` getBkpEnv
425
426 -- | Apply a function on 'DynFlags' on an 'HscEnv'
427 overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
428 overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
429
430 -- | Run a 'BkpM' computation, with the nesting level bumped one.
431 innerBkpM :: BkpM a -> BkpM a
432 innerBkpM do_this = do
433 -- NB: withTempSession mutates, so we don't have to worry
434 -- about bkp_session being stale.
435 updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
436
437 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
438 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
439 updateEpsGhc_ f = do
440 hsc_env <- getSession
441 liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
442
443 -- | Get the EPS from a 'GhcMonad'.
444 getEpsGhc :: GhcMonad m => m ExternalPackageState
445 getEpsGhc = do
446 hsc_env <- getSession
447 liftIO $ readIORef (hsc_EPS hsc_env)
448
449 -- | Run 'BkpM' in 'Ghc'.
450 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
451 initBkpM file bkp m = do
452 reifyGhc $ \session -> do
453 let env = BkpEnv {
454 bkp_session = session,
455 bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
456 bkp_filename = file,
457 bkp_level = 0
458 }
459 runIOEnv env m
460
461 -- ----------------------------------------------------------------------------
462 -- Messaging
463
464 -- | Print a compilation progress message, but with indentation according
465 -- to @level@ (for nested compilation).
466 backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
467 backpackProgressMsg level dflags msg =
468 compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
469
470 -- | Creates a 'Messager' for Backpack compilation; this is basically
471 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
472 -- handles indentation.
473 mkBackpackMsg :: BkpM Messager
474 mkBackpackMsg = do
475 level <- getBkpLevel
476 return $ \hsc_env mod_index recomp mod_summary ->
477 let dflags = hsc_dflags hsc_env
478 showMsg msg reason =
479 backpackProgressMsg level dflags $
480 showModuleIndex mod_index ++
481 msg ++ showModMsg dflags (hscTarget dflags)
482 (recompileRequired recomp) mod_summary
483 ++ reason
484 in case recomp of
485 MustCompile -> showMsg "Compiling " ""
486 UpToDate
487 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
488 | otherwise -> return ()
489 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
490
491 -- | 'PprStyle' for Backpack messages; here we usually want the module to
492 -- be qualified (so we can tell how it was instantiated.) But we try not
493 -- to qualify packages so we can use simple names for them.
494 backpackStyle :: PprStyle
495 backpackStyle =
496 mkUserStyle
497 (QueryQualify neverQualifyNames
498 alwaysQualifyModules
499 neverQualifyPackages) AllTheWay
500
501 -- | Message when we initially process a Backpack unit.
502 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
503 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
504 dflags <- getDynFlags
505 level <- getBkpLevel
506 liftIO . backpackProgressMsg level dflags
507 $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
508
509 -- | Message when we instantiate a Backpack unit.
510 msgUnitId :: UnitId -> BkpM ()
511 msgUnitId pk = do
512 dflags <- getDynFlags
513 level <- getBkpLevel
514 liftIO . backpackProgressMsg level dflags
515 $ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
516
517 -- | Message when we include a Backpack unit.
518 msgInclude :: (Int,Int) -> UnitId -> BkpM ()
519 msgInclude (i,n) uid = do
520 dflags <- getDynFlags
521 level <- getBkpLevel
522 liftIO . backpackProgressMsg level dflags
523 $ showModuleIndex (i, n) ++ "Including " ++
524 renderWithStyle dflags (ppr uid) backpackStyle
525
526 -- ----------------------------------------------------------------------------
527 -- Conversion from PackageName to HsComponentId
528
529 type PackageNameMap a = Map PackageName a
530
531 -- For now, something really simple, since we're not actually going
532 -- to use this for anything
533 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
534 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
535 = (pn, HsComponentId pn (ComponentId fs))
536
537 packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
538 packageNameMap units = Map.fromList (map unitDefines units)
539
540 renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
541 renameHsUnits dflags m units = map (fmap renameHsUnit) units
542 where
543
544 renamePackageName :: PackageName -> HsComponentId
545 renamePackageName pn =
546 case Map.lookup pn m of
547 Nothing ->
548 case lookupPackageName dflags pn of
549 Nothing -> error "no package name"
550 Just cid -> HsComponentId pn cid
551 Just hscid -> hscid
552
553 renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
554 renameHsUnit u =
555 HsUnit {
556 hsunitName = fmap renamePackageName (hsunitName u),
557 hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
558 }
559
560 renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
561 renameHsUnitDecl (DeclD a b c) = DeclD a b c
562 renameHsUnitDecl (IncludeD idecl) =
563 IncludeD IncludeDecl {
564 idUnitId = fmap renameHsUnitId (idUnitId idecl),
565 idModRenaming = idModRenaming idecl
566 }
567
568 renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
569 renameHsUnitId (HsUnitId ln subst)
570 = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
571
572 renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
573 renameHsModuleSubst (lk, lm)
574 = (lk, fmap renameHsModuleId lm)
575
576 renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
577 renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
578 renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
579
580 convertHsUnitId :: HsUnitId HsComponentId -> UnitId
581 convertHsUnitId (HsUnitId (L _ hscid) subst)
582 = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
583
584 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
585 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
586
587 convertHsModuleId :: HsModuleId HsComponentId -> Module
588 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
589 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
590
591
592
593 {-
594 ************************************************************************
595 * *
596 Module graph construction
597 * *
598 ************************************************************************
599 -}
600
601 -- | This is our version of GhcMake.downsweep, but with a few modifications:
602 --
603 -- 1. Every module is required to be mentioned, so we don't do any funny
604 -- business with targets or recursively grabbing dependencies. (We
605 -- could support this in principle).
606 -- 2. We support inline modules, whose summary we have to synthesize ourself.
607 --
608 -- We don't bother trying to support GhcMake for now, it's more trouble
609 -- than it's worth for inline modules.
610 hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
611 hsunitModuleGraph dflags unit = do
612 let decls = hsunitBody unit
613 pn = hsPackageName (unLoc (hsunitName unit))
614
615 -- 1. Create a HsSrcFile/HsigFile summary for every
616 -- explicitly mentioned module/signature.
617 let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
618 let hsc_src = case dt of
619 ModuleD -> HsSrcFile
620 SignatureD -> HsigFile
621 Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
622 get_decl _ = return Nothing
623 nodes <- catMaybes `fmap` mapM get_decl decls
624
625 -- 2. For each hole which does not already have an hsig file,
626 -- create an "empty" hsig file to induce compilation for the
627 -- requirement.
628 let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
629 | n <- nodes ]
630 req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
631 let has_local = Map.member (mod_name, True) node_map
632 in if has_local
633 then return Nothing
634 else fmap Just $ summariseRequirement pn mod_name
635
636 -- 3. Return the kaboodle
637 return (nodes ++ req_nodes)
638
639 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
640 summariseRequirement pn mod_name = do
641 hsc_env <- getSession
642 let dflags = hsc_dflags hsc_env
643
644 let PackageName pn_fs = pn
645 location <- liftIO $ mkHomeModLocation2 dflags mod_name
646 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
647
648 env <- getBkpEnv
649 time <- liftIO $ getModificationUTCTime (bkp_filename env)
650 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
651 let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
652
653 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
654
655 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
656
657 return ModSummary {
658 ms_mod = mod,
659 ms_hsc_src = HsigFile,
660 ms_location = location,
661 ms_hs_date = time,
662 ms_obj_date = Nothing,
663 ms_iface_date = hi_timestamp,
664 ms_srcimps = [],
665 ms_textual_imps = extra_sig_imports,
666 ms_parsed_mod = Just (HsParsedModule {
667 hpm_module = L loc (HsModule {
668 hsmodName = Just (L loc mod_name),
669 hsmodExports = Nothing,
670 hsmodImports = [],
671 hsmodDecls = [],
672 hsmodDeprecMessage = Nothing,
673 hsmodHaddockModHeader = Nothing
674 }),
675 hpm_src_files = [],
676 hpm_annotations = (Map.empty, Map.empty)
677 }),
678 ms_hspp_file = "", -- none, it came inline
679 ms_hspp_opts = dflags,
680 ms_hspp_buf = Nothing
681 }
682
683 summariseDecl :: PackageName
684 -> HscSource
685 -> Located ModuleName
686 -> Maybe (Located (HsModule RdrName))
687 -> BkpM ModSummary
688 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
689 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
690 = do hsc_env <- getSession
691 let dflags = hsc_dflags hsc_env
692 -- TODO: this looks for modules in the wrong place
693 r <- liftIO $ summariseModule hsc_env
694 Map.empty -- GHC API recomp not supported
695 (hscSourceToIsBoot hsc_src)
696 lmodname
697 True -- Target lets you disallow, but not here
698 Nothing -- GHC API buffer support not supported
699 [] -- No exclusions
700 case r of
701 Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
702 Just (Left err) -> throwOneError err
703 Just (Right summary) -> return summary
704
705 -- | Up until now, GHC has assumed a single compilation target per source file.
706 -- Backpack files with inline modules break this model, since a single file
707 -- may generate multiple output files. How do we decide to name these files?
708 -- Should there only be one output file? This function our current heuristic,
709 -- which is we make a "fake" module and use that.
710 hsModuleToModSummary :: PackageName
711 -> HscSource
712 -> ModuleName
713 -> Located (HsModule RdrName)
714 -> BkpM ModSummary
715 hsModuleToModSummary pn hsc_src modname
716 hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
717 hsc_env <- getSession
718 -- Sort of the same deal as in DriverPipeline's getLocation
719 -- Use the PACKAGE NAME to find the location
720 let PackageName unit_fs = pn
721 dflags = hsc_dflags hsc_env
722 -- Unfortunately, we have to define a "fake" location in
723 -- order to appease the various code which uses the file
724 -- name to figure out where to put, e.g. object files.
725 -- To add insult to injury, we don't even actually use
726 -- these filenames to figure out where the hi files go.
727 -- A travesty!
728 location0 <- liftIO $ mkHomeModLocation2 dflags modname
729 (unpackFS unit_fs </>
730 moduleNameSlashes modname)
731 (case hsc_src of
732 HsigFile -> "hsig"
733 HsBootFile -> "hs-boot"
734 HsSrcFile -> "hs")
735 -- DANGEROUS: bootifying can POISON the module finder cache
736 let location = case hsc_src of
737 HsBootFile -> addBootSuffixLocn location0
738 _ -> location0
739 -- This duplicates a pile of logic in GhcMake
740 env <- getBkpEnv
741 time <- liftIO $ getModificationUTCTime (bkp_filename env)
742 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
743
744 -- Also copied from 'getImports'
745 let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
746
747 -- GHC.Prim doesn't exist physically, so don't go looking for it.
748 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
749 ord_idecls
750
751 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
752 implicit_imports = mkPrelImports modname loc
753 implicit_prelude imps
754 convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
755
756 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
757
758 let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
759 required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
760
761 -- So that Finder can find it, even though it doesn't exist...
762 this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
763 return ModSummary {
764 ms_mod = this_mod,
765 ms_hsc_src = hsc_src,
766 ms_location = location,
767 ms_hspp_file = (case hiDir dflags of
768 Nothing -> ""
769 Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
770 ms_hspp_opts = dflags,
771 ms_hspp_buf = Nothing,
772 ms_srcimps = map convImport src_idecls,
773 ms_textual_imps = normal_imports
774 -- We have to do something special here:
775 -- due to merging, requirements may end up with
776 -- extra imports
777 ++ extra_sig_imports
778 ++ required_by_imports,
779 -- This is our hack to get the parse tree to the right spot
780 ms_parsed_mod = Just (HsParsedModule {
781 hpm_module = hsmod,
782 hpm_src_files = [], -- TODO if we preprocessed it
783 hpm_annotations = (Map.empty, Map.empty) -- BOGUS
784 }),
785 ms_hs_date = time,
786 ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
787 ms_iface_date = hi_timestamp
788 }
789
790 -- | Create a new, externally provided hashed unit id from
791 -- a hash.
792 newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
793 newInstalledUnitId (ComponentId cid_fs) (Just fs)
794 = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
795 newInstalledUnitId (ComponentId cid_fs) Nothing
796 = InstalledUnitId cid_fs