Distinguish between UnitId and InstalledUnitId.
[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 = insts,
159 thisPackage =
160 case session_type of
161 TcSession -> newUnitId cid insts
162 -- No hash passed if no instances
163 _ | null insts -> newSimpleUnitId cid
164 | otherwise -> newDefiniteUnitId cid (Just (hashUnitId cid insts)),
165 -- Setup all of the output directories according to our hierarchy
166 objectDir = Just (outdir objectDir),
167 hiDir = Just (outdir hiDir),
168 stubDir = Just (outdir stubDir),
169 -- Unset output-file for non exe builds
170 outputFile = if session_type == ExeSession
171 then outputFile dflags
172 else Nothing,
173 -- Synthesized the flags
174 packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
175 let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
176 in ExposePackage
177 (showSDoc dflags
178 (text "-unit-id" <+> ppr uid <+> ppr rn))
179 (UnitIdArg uid) rn) deps
180 } )) $ do
181 dflags <- getSessionDynFlags
182 -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
183 -- Calls initPackages
184 _ <- setSessionDynFlags dflags
185 do_this
186
187 withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
188 withBkpExeSession deps do_this = do
189 withBkpSession (unitIdComponentId mainUnitId) [] deps ExeSession do_this
190
191 getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
192 getSource cid = do
193 bkp_env <- getBkpEnv
194 case Map.lookup cid (bkp_table bkp_env) of
195 Nothing -> pprPanic "missing needed dependency" (ppr cid)
196 Just lunit -> return lunit
197
198 typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
199 typecheckUnit cid insts = do
200 lunit <- getSource cid
201 buildUnit TcSession cid insts lunit
202
203 compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
204 compileUnit cid insts = do
205 -- Let everyone know we're building this unit ID
206 msgUnitId (newUnitId cid insts)
207 lunit <- getSource cid
208 buildUnit CompSession cid insts lunit
209
210 -- Invariant: this NEVER returns InstalledUnitId
211 hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
212 hsunitDeps unit = concatMap get_dep (hsunitBody unit)
213 where
214 get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)]
215 where go Nothing = ModRenaming True []
216 go (Just lrns) = ModRenaming False (map convRn lrns)
217 where convRn (L _ (Renaming from to)) = (from, to)
218 get_dep _ = []
219
220 buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
221 buildUnit session cid insts lunit = do
222 let deps_w_rns = hsunitDeps (unLoc lunit)
223 raw_deps = map fst deps_w_rns
224 dflags <- getDynFlags
225 -- The compilation dependencies are just the appropriately filled
226 -- in unit IDs which must be compiled before we can compile.
227 let hsubst = listToUFM insts
228 deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
229
230 -- Build dependencies OR make sure they make sense. BUT NOTE,
231 -- we can only check the ones that are fully filled; the rest
232 -- we have to defer until we've typechecked our local signature.
233 -- TODO: work this into GhcMake!!
234 forM_ (zip [1..] deps0) $ \(i, dep) ->
235 case session of
236 TcSession -> return ()
237 _ -> compileInclude (length deps0) (i, dep)
238
239 dflags <- getDynFlags
240 -- IMPROVE IT
241 let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
242
243 mb_old_eps <- case session of
244 TcSession -> fmap Just getEpsGhc
245 _ -> return Nothing
246
247 conf <- withBkpSession cid insts deps_w_rns session $ do
248
249 dflags <- getDynFlags
250 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
251 -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
252
253 msg <- mkBackpackMsg
254 ok <- load' LoadAllTargets (Just msg) mod_graph
255 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
256
257 let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
258 export_mod ms = (ms_mod_name ms, ms_mod ms)
259 -- Export everything!
260 mods = [ export_mod ms | ms <- mod_graph, ms_hsc_src ms == HsSrcFile ]
261
262 -- Compile relevant only
263 hsc_env <- getSession
264 let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
265 linkables = map (expectJust "bkp link" . hm_linkable)
266 . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
267 $ home_mod_infos
268 getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
269 obj_files = concatMap getOfiles linkables
270
271 let compat_fs = (case cid of ComponentId fs -> fs)
272 cand_compat_pn = PackageName compat_fs
273 compat_pn = case session of
274 TcSession -> cand_compat_pn
275 _ | [] <- insts -> cand_compat_pn
276 | otherwise -> PackageName compat_fs
277
278 return InstalledPackageInfo {
279 -- Stub data
280 abiHash = "",
281 sourcePackageId = SourcePackageId compat_fs,
282 packageName = compat_pn,
283 packageVersion = makeVersion [0],
284 unitId = toInstalledUnitId (thisPackage dflags),
285 instantiatedWith = insts,
286 -- Slight inefficiency here haha
287 exposedModules = map (\(m,n) -> (m,Just n)) mods,
288 hiddenModules = [], -- TODO: doc only
289 depends = case session of
290 -- Technically, we should state that we depend
291 -- on all the indefinite libraries we used to
292 -- typecheck this. However, this field isn't
293 -- really used for anything, so we leave it
294 -- blank for now.
295 TcSession -> []
296 _ -> map (toInstalledUnitId . unwireUnitId dflags)
297 $ deps ++ [ moduleUnitId mod
298 | (_, mod) <- insts
299 , not (isHoleModule mod) ],
300 ldOptions = case session of
301 TcSession -> []
302 _ -> obj_files,
303 importDirs = [ hi_dir ],
304 exposed = False,
305 indefinite = case session of
306 TcSession -> True
307 _ -> False,
308 -- nope
309 hsLibraries = [],
310 extraLibraries = [],
311 extraGHCiLibraries = [],
312 libraryDirs = [],
313 frameworks = [],
314 frameworkDirs = [],
315 ccOptions = [],
316 includes = [],
317 includeDirs = [],
318 haddockInterfaces = [],
319 haddockHTMLs = [],
320 trusted = False
321 }
322
323
324 addPackage conf
325 case mb_old_eps of
326 Just old_eps -> updateEpsGhc_ (const old_eps)
327 _ -> return ()
328
329 compileExe :: LHsUnit HsComponentId -> BkpM ()
330 compileExe lunit = do
331 msgUnitId mainUnitId
332 let deps_w_rns = hsunitDeps (unLoc lunit)
333 deps = map fst deps_w_rns
334 -- no renaming necessary
335 forM_ (zip [1..] deps) $ \(i, dep) ->
336 compileInclude (length deps) (i, dep)
337 withBkpExeSession deps_w_rns $ do
338 dflags <- getDynFlags
339 mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
340 msg <- mkBackpackMsg
341 ok <- load' LoadAllTargets (Just msg) mod_graph
342 when (failed ok) (liftIO $ exitWith (ExitFailure 1))
343
344 addPackage :: GhcMonad m => PackageConfig -> m ()
345 addPackage pkg = do
346 dflags0 <- GHC.getSessionDynFlags
347 case pkgDatabase dflags0 of
348 Nothing -> panic "addPackage: called too early"
349 Just pkgs -> do let dflags = dflags0 { pkgDatabase =
350 Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
351 _ <- GHC.setSessionDynFlags dflags
352 -- By this time, the global ref has probably already
353 -- been forced, in which case doing this isn't actually
354 -- going to do you any good.
355 -- dflags <- GHC.getSessionDynFlags
356 -- liftIO $ setUnsafeGlobalDynFlags dflags
357 return ()
358
359 -- Precondition: UnitId is NOT InstalledUnitId
360 compileInclude :: Int -> (Int, UnitId) -> BkpM ()
361 compileInclude n (i, uid) = do
362 hsc_env <- getSession
363 let dflags = hsc_dflags hsc_env
364 msgInclude (i, n) uid
365 -- Check if we've compiled it already
366 case lookupPackage dflags uid of
367 Nothing -> do
368 case splitUnitIdInsts uid of
369 (_, Just insts) ->
370 innerBkpM $ compileUnit (unitIdComponentId uid) insts
371 _ -> return ()
372 Just _ -> return ()
373
374 -- ----------------------------------------------------------------------------
375 -- Backpack monad
376
377 -- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
378 -- beyond the 'Session', c.f. 'BkpEnv'.
379 type BkpM = IOEnv BkpEnv
380
381 -- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
382 -- because we are going to update the 'HscEnv' as we go.
383 data BkpEnv
384 = BkpEnv {
385 -- | The session
386 bkp_session :: Session,
387 -- | The filename of the bkp file we're compiling
388 bkp_filename :: FilePath,
389 -- | Table of source units which we know how to compile
390 bkp_table :: Map ComponentId (LHsUnit HsComponentId),
391 -- | When a package we are compiling includes another package
392 -- which has not been compiled, we bump the level and compile
393 -- that.
394 bkp_level :: Int
395 }
396
397 -- Blah, to get rid of the default instance for IOEnv
398 -- TODO: just make a proper new monad for BkpM, rather than use IOEnv
399 instance {-# OVERLAPPING #-} HasDynFlags BkpM where
400 getDynFlags = fmap hsc_dflags getSession
401
402 instance GhcMonad BkpM where
403 getSession = do
404 Session s <- fmap bkp_session getEnv
405 readMutVar s
406 setSession hsc_env = do
407 Session s <- fmap bkp_session getEnv
408 writeMutVar s hsc_env
409
410 -- | Get the current 'BkpEnv'.
411 getBkpEnv :: BkpM BkpEnv
412 getBkpEnv = getEnv
413
414 -- | Get the nesting level, when recursively compiling modules.
415 getBkpLevel :: BkpM Int
416 getBkpLevel = bkp_level `fmap` getBkpEnv
417
418 -- | Apply a function on 'DynFlags' on an 'HscEnv'
419 overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
420 overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
421
422 -- | Run a 'BkpM' computation, with the nesting level bumped one.
423 innerBkpM :: BkpM a -> BkpM a
424 innerBkpM do_this = do
425 -- NB: withTempSession mutates, so we don't have to worry
426 -- about bkp_session being stale.
427 updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
428
429 -- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
430 updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
431 updateEpsGhc_ f = do
432 hsc_env <- getSession
433 liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
434
435 -- | Get the EPS from a 'GhcMonad'.
436 getEpsGhc :: GhcMonad m => m ExternalPackageState
437 getEpsGhc = do
438 hsc_env <- getSession
439 liftIO $ readIORef (hsc_EPS hsc_env)
440
441 -- | Run 'BkpM' in 'Ghc'.
442 initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
443 initBkpM file bkp m = do
444 reifyGhc $ \session -> do
445 let env = BkpEnv {
446 bkp_session = session,
447 bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
448 bkp_filename = file,
449 bkp_level = 0
450 }
451 runIOEnv env m
452
453 -- ----------------------------------------------------------------------------
454 -- Messaging
455
456 -- | Print a compilation progress message, but with indentation according
457 -- to @level@ (for nested compilation).
458 backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
459 backpackProgressMsg level dflags msg =
460 compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
461
462 -- | Creates a 'Messager' for Backpack compilation; this is basically
463 -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
464 -- handles indentation.
465 mkBackpackMsg :: BkpM Messager
466 mkBackpackMsg = do
467 level <- getBkpLevel
468 return $ \hsc_env mod_index recomp mod_summary ->
469 let dflags = hsc_dflags hsc_env
470 showMsg msg reason =
471 backpackProgressMsg level dflags $
472 showModuleIndex mod_index ++
473 msg ++ showModMsg dflags (hscTarget dflags)
474 (recompileRequired recomp) mod_summary
475 ++ reason
476 in case recomp of
477 MustCompile -> showMsg "Compiling " ""
478 UpToDate
479 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
480 | otherwise -> return ()
481 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
482
483 -- | 'PprStyle' for Backpack messages; here we usually want the module to
484 -- be qualified (so we can tell how it was instantiated.) But we try not
485 -- to qualify packages so we can use simple names for them.
486 backpackStyle :: PprStyle
487 backpackStyle =
488 mkUserStyle
489 (QueryQualify neverQualifyNames
490 alwaysQualifyModules
491 neverQualifyPackages) AllTheWay
492
493 -- | Message when we initially process a Backpack unit.
494 msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
495 msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
496 dflags <- getDynFlags
497 level <- getBkpLevel
498 liftIO . backpackProgressMsg level dflags
499 $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
500
501 -- | Message when we instantiate a Backpack unit.
502 msgUnitId :: UnitId -> BkpM ()
503 msgUnitId pk = do
504 dflags <- getDynFlags
505 level <- getBkpLevel
506 liftIO . backpackProgressMsg level dflags
507 $ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle
508
509 -- | Message when we include a Backpack unit.
510 msgInclude :: (Int,Int) -> UnitId -> BkpM ()
511 msgInclude (i,n) uid = do
512 dflags <- getDynFlags
513 level <- getBkpLevel
514 liftIO . backpackProgressMsg level dflags
515 $ showModuleIndex (i, n) ++ "Including " ++
516 renderWithStyle dflags (ppr uid) backpackStyle
517
518 -- ----------------------------------------------------------------------------
519 -- Conversion from PackageName to HsComponentId
520
521 type PackageNameMap a = Map PackageName a
522
523 -- For now, something really simple, since we're not actually going
524 -- to use this for anything
525 unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
526 unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
527 = (pn, HsComponentId pn (ComponentId fs))
528
529 packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
530 packageNameMap units = Map.fromList (map unitDefines units)
531
532 renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
533 renameHsUnits dflags m units = map (fmap renameHsUnit) units
534 where
535
536 renamePackageName :: PackageName -> HsComponentId
537 renamePackageName pn =
538 case Map.lookup pn m of
539 Nothing ->
540 case lookupPackageName dflags pn of
541 Nothing -> error "no package name"
542 Just cid -> HsComponentId pn cid
543 Just hscid -> hscid
544
545 renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
546 renameHsUnit u =
547 HsUnit {
548 hsunitName = fmap renamePackageName (hsunitName u),
549 hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
550 }
551
552 renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
553 renameHsUnitDecl (DeclD a b c) = DeclD a b c
554 renameHsUnitDecl (IncludeD idecl) =
555 IncludeD IncludeDecl {
556 idUnitId = fmap renameHsUnitId (idUnitId idecl),
557 idModRenaming = idModRenaming idecl
558 }
559
560 renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
561 renameHsUnitId (HsUnitId ln subst)
562 = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
563
564 renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
565 renameHsModuleSubst (lk, lm)
566 = (lk, fmap renameHsModuleId lm)
567
568 renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
569 renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
570 renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
571
572 convertHsUnitId :: HsUnitId HsComponentId -> UnitId
573 convertHsUnitId (HsUnitId (L _ hscid) subst)
574 = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
575
576 convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
577 convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
578
579 convertHsModuleId :: HsModuleId HsComponentId -> Module
580 convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
581 convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
582
583
584
585 {-
586 ************************************************************************
587 * *
588 Module graph construction
589 * *
590 ************************************************************************
591 -}
592
593 -- | This is our version of GhcMake.downsweep, but with a few modifications:
594 --
595 -- 1. Every module is required to be mentioned, so we don't do any funny
596 -- business with targets or recursively grabbing dependencies. (We
597 -- could support this in principle).
598 -- 2. We support inline modules, whose summary we have to synthesize ourself.
599 --
600 -- We don't bother trying to support GhcMake for now, it's more trouble
601 -- than it's worth for inline modules.
602 hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
603 hsunitModuleGraph dflags unit = do
604 let decls = hsunitBody unit
605 pn = hsPackageName (unLoc (hsunitName unit))
606
607 -- 1. Create a HsSrcFile/HsigFile summary for every
608 -- explicitly mentioned module/signature.
609 let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
610 let hsc_src = case dt of
611 ModuleD -> HsSrcFile
612 SignatureD -> HsigFile
613 Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
614 get_decl _ = return Nothing
615 nodes <- catMaybes `fmap` mapM get_decl decls
616
617 -- 2. For each hole which does not already have an hsig file,
618 -- create an "empty" hsig file to induce compilation for the
619 -- requirement.
620 let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
621 | n <- nodes ]
622 req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
623 let has_local = Map.member (mod_name, True) node_map
624 in if has_local
625 then return Nothing
626 else fmap Just $ summariseRequirement pn mod_name
627
628 -- 3. Return the kaboodle
629 return (nodes ++ req_nodes)
630
631 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
632 summariseRequirement pn mod_name = do
633 hsc_env <- getSession
634 let dflags = hsc_dflags hsc_env
635
636 let PackageName pn_fs = pn
637 location <- liftIO $ mkHomeModLocation2 dflags mod_name
638 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
639
640 env <- getBkpEnv
641 time <- liftIO $ getModificationUTCTime (bkp_filename env)
642 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
643 let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
644
645 mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
646
647 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
648
649 return ModSummary {
650 ms_mod = mod,
651 ms_hsc_src = HsigFile,
652 ms_location = location,
653 ms_hs_date = time,
654 ms_obj_date = Nothing,
655 ms_iface_date = hi_timestamp,
656 ms_srcimps = [],
657 ms_textual_imps = extra_sig_imports,
658 ms_parsed_mod = Just (HsParsedModule {
659 hpm_module = L loc (HsModule {
660 hsmodName = Just (L loc mod_name),
661 hsmodExports = Nothing,
662 hsmodImports = [],
663 hsmodDecls = [],
664 hsmodDeprecMessage = Nothing,
665 hsmodHaddockModHeader = Nothing
666 }),
667 hpm_src_files = [],
668 hpm_annotations = (Map.empty, Map.empty)
669 }),
670 ms_hspp_file = "", -- none, it came inline
671 ms_hspp_opts = dflags,
672 ms_hspp_buf = Nothing
673 }
674
675 summariseDecl :: PackageName
676 -> HscSource
677 -> Located ModuleName
678 -> Maybe (Located (HsModule RdrName))
679 -> BkpM ModSummary
680 summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
681 summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
682 = do hsc_env <- getSession
683 let dflags = hsc_dflags hsc_env
684 -- TODO: this looks for modules in the wrong place
685 r <- liftIO $ summariseModule hsc_env
686 Map.empty -- GHC API recomp not supported
687 (hscSourceToIsBoot hsc_src)
688 lmodname
689 True -- Target lets you disallow, but not here
690 Nothing -- GHC API buffer support not supported
691 [] -- No exclusions
692 case r of
693 Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
694 Just (Left err) -> throwOneError err
695 Just (Right summary) -> return summary
696
697 -- | Up until now, GHC has assumed a single compilation target per source file.
698 -- Backpack files with inline modules break this model, since a single file
699 -- may generate multiple output files. How do we decide to name these files?
700 -- Should there only be one output file? This function our current heuristic,
701 -- which is we make a "fake" module and use that.
702 hsModuleToModSummary :: PackageName
703 -> HscSource
704 -> ModuleName
705 -> Located (HsModule RdrName)
706 -> BkpM ModSummary
707 hsModuleToModSummary pn hsc_src modname
708 hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
709 hsc_env <- getSession
710 -- Sort of the same deal as in DriverPipeline's getLocation
711 -- Use the PACKAGE NAME to find the location
712 let PackageName unit_fs = pn
713 dflags = hsc_dflags hsc_env
714 -- Unfortunately, we have to define a "fake" location in
715 -- order to appease the various code which uses the file
716 -- name to figure out where to put, e.g. object files.
717 -- To add insult to injury, we don't even actually use
718 -- these filenames to figure out where the hi files go.
719 -- A travesty!
720 location0 <- liftIO $ mkHomeModLocation2 dflags modname
721 (unpackFS unit_fs </>
722 moduleNameSlashes modname)
723 (case hsc_src of
724 HsigFile -> "hsig"
725 HsBootFile -> "hs-boot"
726 HsSrcFile -> "hs")
727 -- DANGEROUS: bootifying can POISON the module finder cache
728 let location = case hsc_src of
729 HsBootFile -> addBootSuffixLocn location0
730 _ -> location0
731 -- This duplicates a pile of logic in GhcMake
732 env <- getBkpEnv
733 time <- liftIO $ getModificationUTCTime (bkp_filename env)
734 hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
735
736 -- Also copied from 'getImports'
737 let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
738
739 -- GHC.Prim doesn't exist physically, so don't go looking for it.
740 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
741 ord_idecls
742
743 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
744 implicit_imports = mkPrelImports modname loc
745 implicit_prelude imps
746 convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
747
748 extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
749
750 let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
751 required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
752
753 -- So that Finder can find it, even though it doesn't exist...
754 this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
755 return ModSummary {
756 ms_mod = this_mod,
757 ms_hsc_src = hsc_src,
758 ms_location = location,
759 ms_hspp_file = (case hiDir dflags of
760 Nothing -> ""
761 Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
762 ms_hspp_opts = dflags,
763 ms_hspp_buf = Nothing,
764 ms_srcimps = map convImport src_idecls,
765 ms_textual_imps = normal_imports
766 -- We have to do something special here:
767 -- due to merging, requirements may end up with
768 -- extra imports
769 ++ extra_sig_imports
770 ++ required_by_imports,
771 -- This is our hack to get the parse tree to the right spot
772 ms_parsed_mod = Just (HsParsedModule {
773 hpm_module = hsmod,
774 hpm_src_files = [], -- TODO if we preprocessed it
775 hpm_annotations = (Map.empty, Map.empty) -- BOGUS
776 }),
777 ms_hs_date = time,
778 ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
779 ms_iface_date = hi_timestamp
780 }