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