cdbe06d51f0ba36ae2b6448853e16749c72fd59c
[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 ldOptions = case session of
306 TcSession -> []
307 _ -> obj_files,
308 importDirs = [ hi_dir ],
309 exposed = False,
310 indefinite = case session of
311 TcSession -> True
312 _ -> False,
313 -- nope
314 hsLibraries = [],
315 extraLibraries = [],
316 extraGHCiLibraries = [],
317 libraryDynDirs = [],
318 libraryDirs = [],
319 frameworks = [],
320 frameworkDirs = [],
321 ccOptions = [],
322 includes = [],
323 includeDirs = [],
324 haddockInterfaces = [],
325 haddockHTMLs = [],
326 trusted = False
327 }
328
329
330 addPackage conf
331 case mb_old_eps of
332 Just old_eps -> updateEpsGhc_ (const old_eps)
333 _ -> return ()
334
335 compileExe :: LHsUnit HsComponentId -> BkpM ()
336 compileExe lunit = do
337 msgUnitId mainUnitId
338 let deps_w_rns = hsunitDeps (unLoc lunit)
339 deps = map fst deps_w_rns
340 -- no renaming necessary
341 forM_ (zip [1..] deps) $ \(i, dep) ->
342 compileInclude (length deps) (i, dep)
343 withBkpExeSession deps_w_rns $ do
344 dflags <- getDynFlags
345 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
346 msg <- mkBackpackMsg
347 ok <- load' LoadAllTargets (Just msg) mod_graph
348 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
349
350 addPackage :: GhcMonad m => PackageConfig -> m ()
351 addPackage pkg = do
352 dflags0 <- GHC.getSessionDynFlags
353 case pkgDatabase dflags0 of
354 Nothing -> panic "addPackage: called too early"
355 Just pkgs -> do let dflags = dflags0 { pkgDatabase =
356 Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
357 _ <- GHC.setSessionDynFlags dflags
358 -- By this time, the global ref has probably already
359 -- been forced, in which case doing this isn't actually
360 -- going to do you any good.
361 -- dflags <- GHC.getSessionDynFlags
362 -- liftIO $ setUnsafeGlobalDynFlags dflags
363 return ()
364
365 -- Precondition: UnitId is NOT InstalledUnitId
366 compileInclude :: Int -> (Int, UnitId) -> BkpM ()
367 compileInclude n (i, uid) = do
368 hsc_env <- getSession
369 let dflags = hsc_dflags hsc_env
370 msgInclude (i, n) uid
371 -- Check if we've compiled it already
372 case lookupPackage dflags uid of
373 Nothing -> do
374 case splitUnitIdInsts uid of
375 (_, Just indef) ->
376 innerBkpM $ compileUnit (indefUnitIdComponentId indef)
377 (indefUnitIdInsts indef)
378 _ -> return ()
379 Just _ -> return ()
380
381 -- ----------------------------------------------------------------------------
382 -- Backpack monad
383
384 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
385 -- beyond the 'Session', c.f. 'BkpEnv'.
386 type BkpM = IOEnv BkpEnv
387
388 -- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
389 -- because we are going to update the 'HscEnv' as we go.
390 data BkpEnv
391 = BkpEnv {
392 -- | The session
393 bkp_session :: Session,
394 -- | The filename of the bkp file we're compiling
395 bkp_filename :: FilePath,
396 -- | Table of source units which we know how to compile
397 bkp_table :: Map ComponentId (LHsUnit HsComponentId),
398 -- | When a package we are compiling includes another package
399 -- which has not been compiled, we bump the level and compile
400 -- that.
401 bkp_level :: Int
402 }
403
404 -- Blah, to get rid of the default instance for IOEnv
405 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
406 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
407 getDynFlags = fmap hsc_dflags getSession
408
409 instance GhcMonad BkpM where
410 getSession = do
411 Session s <- fmap bkp_session getEnv
412 readMutVar s
413 setSession hsc_env = do
414 Session s <- fmap bkp_session getEnv
415 writeMutVar s hsc_env
416
417 -- | Get the current 'BkpEnv'.
418 getBkpEnv :: BkpM BkpEnv
419 getBkpEnv = getEnv
420
421 -- | Get the nesting level, when recursively compiling modules.
422 getBkpLevel :: BkpM Int
423 getBkpLevel = bkp_level `fmap` getBkpEnv
424
425 -- | Apply a function on 'DynFlags' on an 'HscEnv'
426 overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
427 overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
428
429 -- | Run a 'BkpM' computation, with the nesting level bumped one.
430 innerBkpM :: BkpM a -> BkpM a
431 innerBkpM do_this = do
432 -- NB: withTempSession mutates, so we don't have to worry
433 -- about bkp_session being stale.
434 updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
435
436 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
437 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
438 updateEpsGhc_ f = do
439 hsc_env <- getSession
440 liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
441
442 -- | Get the EPS from a 'GhcMonad'.
443 getEpsGhc :: GhcMonad m => m ExternalPackageState
444 getEpsGhc = do
445 hsc_env <- getSession
446 liftIO $ readIORef (hsc_EPS hsc_env)
447
448 -- | Run 'BkpM' in 'Ghc'.
449 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
450 initBkpM file bkp m = do
451 reifyGhc $ \session -> do
452 let env = BkpEnv {
453 bkp_session = session,
454 bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
455 bkp_filename = file,
456 bkp_level = 0
457 }
458 runIOEnv env m
459
460 -- ----------------------------------------------------------------------------
461 -- Messaging
462
463 -- | Print a compilation progress message, but with indentation according
464 -- to @level@ (for nested compilation).
465 backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
466 backpackProgressMsg level dflags msg =
467 compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
468
469 -- | Creates a 'Messager' for Backpack compilation; this is basically
470 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
471 -- handles indentation.
472 mkBackpackMsg :: BkpM Messager
473 mkBackpackMsg = do
474 level <- getBkpLevel
475 return $ \hsc_env mod_index recomp mod_summary ->
476 let dflags = hsc_dflags hsc_env
477 showMsg msg reason =
478 backpackProgressMsg level dflags $
479 showModuleIndex mod_index ++
480 msg ++ showModMsg dflags (hscTarget dflags)
481 (recompileRequired recomp) mod_summary
482 ++ reason
483 in case recomp of
484 MustCompile -> showMsg "Compiling " ""
485 UpToDate
486 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
487 | otherwise -> return ()
488 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
489
490 -- | 'PprStyle' for Backpack messages; here we usually want the module to
491 -- be qualified (so we can tell how it was instantiated.) But we try not
492 -- to qualify packages so we can use simple names for them.
493 backpackStyle :: PprStyle
494 backpackStyle =
495 mkUserStyle
496 (QueryQualify neverQualifyNames
497 alwaysQualifyModules
498 neverQualifyPackages) AllTheWay
499
500 -- | Message when we initially process a Backpack unit.
501 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
502 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
503 dflags <- getDynFlags
504 level <- getBkpLevel
505 liftIO . backpackProgressMsg level dflags
506 $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
507
508 -- | Message when we instantiate a Backpack unit.
509 msgUnitId :: UnitId -> BkpM ()
510 msgUnitId pk = do
511 dflags <- getDynFlags
512 level <- getBkpLevel
513 liftIO . backpackProgressMsg level dflags
514 $ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
515
516 -- | Message when we include a Backpack unit.
517 msgInclude :: (Int,Int) -> UnitId -> BkpM ()
518 msgInclude (i,n) uid = do
519 dflags <- getDynFlags
520 level <- getBkpLevel
521 liftIO . backpackProgressMsg level dflags
522 $ showModuleIndex (i, n) ++ "Including " ++
523 renderWithStyle dflags (ppr uid) backpackStyle
524
525 -- ----------------------------------------------------------------------------
526 -- Conversion from PackageName to HsComponentId
527
528 type PackageNameMap a = Map PackageName a
529
530 -- For now, something really simple, since we're not actually going
531 -- to use this for anything
532 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
533 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
534 = (pn, HsComponentId pn (ComponentId fs))
535
536 packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
537 packageNameMap units = Map.fromList (map unitDefines units)
538
539 renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
540 renameHsUnits dflags m units = map (fmap renameHsUnit) units
541 where
542
543 renamePackageName :: PackageName -> HsComponentId
544 renamePackageName pn =
545 case Map.lookup pn m of
546 Nothing ->
547 case lookupPackageName dflags pn of
548 Nothing -> error "no package name"
549 Just cid -> HsComponentId pn cid
550 Just hscid -> hscid
551
552 renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
553 renameHsUnit u =
554 HsUnit {
555 hsunitName = fmap renamePackageName (hsunitName u),
556 hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
557 }
558
559 renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
560 renameHsUnitDecl (DeclD a b c) = DeclD a b c
561 renameHsUnitDecl (IncludeD idecl) =
562 IncludeD IncludeDecl {
563 idUnitId = fmap renameHsUnitId (idUnitId idecl),
564 idModRenaming = idModRenaming idecl
565 }
566
567 renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
568 renameHsUnitId (HsUnitId ln subst)
569 = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
570
571 renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
572 renameHsModuleSubst (lk, lm)
573 = (lk, fmap renameHsModuleId lm)
574
575 renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
576 renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
577 renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
578
579 convertHsUnitId :: HsUnitId HsComponentId -> UnitId
580 convertHsUnitId (HsUnitId (L _ hscid) subst)
581 = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
582
583 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
584 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
585
586 convertHsModuleId :: HsModuleId HsComponentId -> Module
587 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
588 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
589
590
591
592 {-
593 ************************************************************************
594 * *
595 Module graph construction
596 * *
597 ************************************************************************
598 -}
599
600 -- | This is our version of GhcMake.downsweep, but with a few modifications:
601 --
602 -- 1. Every module is required to be mentioned, so we don't do any funny
603 -- business with targets or recursively grabbing dependencies. (We
604 -- could support this in principle).
605 -- 2. We support inline modules, whose summary we have to synthesize ourself.
606 --
607 -- We don't bother trying to support GhcMake for now, it's more trouble
608 -- than it's worth for inline modules.
609 hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
610 hsunitModuleGraph dflags unit = do
611 let decls = hsunitBody unit
612 pn = hsPackageName (unLoc (hsunitName unit))
613
614 -- 1. Create a HsSrcFile/HsigFile summary for every
615 -- explicitly mentioned module/signature.
616 let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
617 let hsc_src = case dt of
618 ModuleD -> HsSrcFile
619 SignatureD -> HsigFile
620 Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
621 get_decl _ = return Nothing
622 nodes <- catMaybes `fmap` mapM get_decl decls
623
624 -- 2. For each hole which does not already have an hsig file,
625 -- create an "empty" hsig file to induce compilation for the
626 -- requirement.
627 let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
628 | n <- nodes ]
629 req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
630 let has_local = Map.member (mod_name, True) node_map
631 in if has_local
632 then return Nothing
633 else fmap Just $ summariseRequirement pn mod_name
634
635 -- 3. Return the kaboodle
636 return (nodes ++ req_nodes)
637
638 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
639 summariseRequirement pn mod_name = do
640 hsc_env <- getSession
641 let dflags = hsc_dflags hsc_env
642
643 let PackageName pn_fs = pn
644 location <- liftIO $ mkHomeModLocation2 dflags mod_name
645 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
646
647 env <- getBkpEnv
648 time <- liftIO $ getModificationUTCTime (bkp_filename env)
649 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
650 let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
651
652 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
653
654 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
655
656 return ModSummary {
657 ms_mod = mod,
658 ms_hsc_src = HsigFile,
659 ms_location = location,
660 ms_hs_date = time,
661 ms_obj_date = Nothing,
662 ms_iface_date = hi_timestamp,
663 ms_srcimps = [],
664 ms_textual_imps = extra_sig_imports,
665 ms_parsed_mod = Just (HsParsedModule {
666 hpm_module = L loc (HsModule {
667 hsmodName = Just (L loc mod_name),
668 hsmodExports = Nothing,
669 hsmodImports = [],
670 hsmodDecls = [],
671 hsmodDeprecMessage = Nothing,
672 hsmodHaddockModHeader = Nothing
673 }),
674 hpm_src_files = [],
675 hpm_annotations = (Map.empty, Map.empty)
676 }),
677 ms_hspp_file = "", -- none, it came inline
678 ms_hspp_opts = dflags,
679 ms_hspp_buf = Nothing
680 }
681
682 summariseDecl :: PackageName
683 -> HscSource
684 -> Located ModuleName
685 -> Maybe (Located (HsModule RdrName))
686 -> BkpM ModSummary
687 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
688 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
689 = do hsc_env <- getSession
690 let dflags = hsc_dflags hsc_env
691 -- TODO: this looks for modules in the wrong place
692 r <- liftIO $ summariseModule hsc_env
693 Map.empty -- GHC API recomp not supported
694 (hscSourceToIsBoot hsc_src)
695 lmodname
696 True -- Target lets you disallow, but not here
697 Nothing -- GHC API buffer support not supported
698 [] -- No exclusions
699 case r of
700 Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
701 Just (Left err) -> throwOneError err
702 Just (Right summary) -> return summary
703
704 -- | Up until now, GHC has assumed a single compilation target per source file.
705 -- Backpack files with inline modules break this model, since a single file
706 -- may generate multiple output files. How do we decide to name these files?
707 -- Should there only be one output file? This function our current heuristic,
708 -- which is we make a "fake" module and use that.
709 hsModuleToModSummary :: PackageName
710 -> HscSource
711 -> ModuleName
712 -> Located (HsModule RdrName)
713 -> BkpM ModSummary
714 hsModuleToModSummary pn hsc_src modname
715 hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
716 hsc_env <- getSession
717 -- Sort of the same deal as in DriverPipeline's getLocation
718 -- Use the PACKAGE NAME to find the location
719 let PackageName unit_fs = pn
720 dflags = hsc_dflags hsc_env
721 -- Unfortunately, we have to define a "fake" location in
722 -- order to appease the various code which uses the file
723 -- name to figure out where to put, e.g. object files.
724 -- To add insult to injury, we don't even actually use
725 -- these filenames to figure out where the hi files go.
726 -- A travesty!
727 location0 <- liftIO $ mkHomeModLocation2 dflags modname
728 (unpackFS unit_fs </>
729 moduleNameSlashes modname)
730 (case hsc_src of
731 HsigFile -> "hsig"
732 HsBootFile -> "hs-boot"
733 HsSrcFile -> "hs")
734 -- DANGEROUS: bootifying can POISON the module finder cache
735 let location = case hsc_src of
736 HsBootFile -> addBootSuffixLocn location0
737 _ -> location0
738 -- This duplicates a pile of logic in GhcMake
739 env <- getBkpEnv
740 time <- liftIO $ getModificationUTCTime (bkp_filename env)
741 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
742
743 -- Also copied from 'getImports'
744 let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
745
746 -- GHC.Prim doesn't exist physically, so don't go looking for it.
747 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
748 ord_idecls
749
750 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
751 implicit_imports = mkPrelImports modname loc
752 implicit_prelude imps
753 convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
754
755 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
756
757 let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
758 required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
759
760 -- So that Finder can find it, even though it doesn't exist...
761 this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
762 return ModSummary {
763 ms_mod = this_mod,
764 ms_hsc_src = hsc_src,
765 ms_location = location,
766 ms_hspp_file = (case hiDir dflags of
767 Nothing -> ""
768 Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
769 ms_hspp_opts = dflags,
770 ms_hspp_buf = Nothing,
771 ms_srcimps = map convImport src_idecls,
772 ms_textual_imps = normal_imports
773 -- We have to do something special here:
774 -- due to merging, requirements may end up with
775 -- extra imports
776 ++ extra_sig_imports
777 ++ required_by_imports,
778 -- This is our hack to get the parse tree to the right spot
779 ms_parsed_mod = Just (HsParsedModule {
780 hpm_module = hsmod,
781 hpm_src_files = [], -- TODO if we preprocessed it
782 hpm_annotations = (Map.empty, Map.empty) -- BOGUS
783 }),
784 ms_hs_date = time,
785 ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
786 ms_iface_date = hi_timestamp
787 }
788
789 -- | Create a new, externally provided hashed unit id from
790 -- a hash.
791 newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
792 newInstalledUnitId (ComponentId cid_fs) (Just fs)
793 = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
794 newInstalledUnitId (ComponentId cid_fs) Nothing
795 = InstalledUnitId cid_fs