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