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