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