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