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