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