Register.hs 8.37 KB
Newer Older
1 2 3 4
module Rules.Register (
    configurePackageRules, registerPackageRules, registerPackages,
    libraryTargets
    ) where
5 6

import Base
7
import Context
8
import Expression ( getContextData )
9 10
import Hadrian.BuildPath
import Hadrian.Expression
11 12
import Hadrian.Haskell.Cabal
import Oracles.Setting
13
import Packages
14
import Rules.Gmp
15
import Rules.Rts
16
import Settings
17
import Target
18
import Utilities
19 20 21

import Hadrian.Haskell.Cabal.Type
import qualified Text.Parsec      as Parsec
22

23
import Distribution.Version (Version)
24 25 26
import qualified Distribution.Parsec as Cabal
import qualified Distribution.Types.PackageName as Cabal
import qualified Distribution.Types.PackageId as Cabal
27 28 29 30 31

import qualified Hadrian.Haskell.Cabal.Parse as Cabal
import qualified System.Directory            as IO

-- * Configuring
32

33 34
-- | Configure a package and build its @setup-config@ file, as well as files in
-- the @build/pkgName/build/autogen@ directory.
35 36
configurePackageRules :: Rules ()
configurePackageRules = do
Andrey Mokhov's avatar
Andrey Mokhov committed
37
    root <- buildRootRules
38 39 40 41 42 43 44 45 46 47 48 49
    root -/- "**/setup-config" %> \out -> do
        (stage, path) <- parsePath (parseSetupConfig root) "<setup config path parser>" out
        let pkg = unsafeFindPackageByPath path
        Cabal.configurePackage (Context stage pkg vanilla)

    root -/- "**/autogen/cabal_macros.h" %> \out -> do
        (stage, path) <- parsePath (parseToBuildSubdirectory root) "<cabal macros path parser>" out
        let pkg = unsafeFindPackageByPath path
        Cabal.buildAutogenFiles (Context stage pkg vanilla)

    root -/- "**/autogen/Paths_*.hs" %> \out ->
        need [takeDirectory out -/- "cabal_macros.h"]
50 51 52

parseSetupConfig :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
parseSetupConfig root = do
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgPath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/setup-config")
    return (stage, pkgPath)

parseToBuildSubdirectory :: FilePath -> Parsec.Parsec String () (Stage, FilePath)
parseToBuildSubdirectory root = do
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgPath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/build/")
    return (stage, pkgPath)
68 69

-- * Registering
Andrey Mokhov's avatar
Andrey Mokhov committed
70

71 72 73 74 75 76 77 78 79
registerPackages :: [Context] -> Action ()
registerPackages ctxs = do
    need =<< mapM pkgRegisteredLibraryFile ctxs

    -- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
    forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do
        ways <- interpretInContext ctx (getLibraryWays <> getRtsWays)
        needRtsSymLinks (stage ctx) ways

80 81
-- | Register a package and initialise the corresponding package database if
-- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
82 83
registerPackageRules :: [(Resource, Int)] -> Stage -> Rules ()
registerPackageRules rs stage = do
84 85 86
    root <- buildRootRules

    -- Initialise the package database.
Andrey Mokhov's avatar
Andrey Mokhov committed
87 88 89
    root -/- relativePackageDbPath stage -/- packageDbStamp %> \stamp ->
        writeFileLines stamp []

90
    -- Register a package.
Andrey Mokhov's avatar
Andrey Mokhov committed
91
    root -/- relativePackageDbPath stage -/- "*.conf" %> \conf -> do
92
        historyDisable
93 94 95 96
        let libpath = takeDirectory (takeDirectory conf)
            settings = libpath -/- "settings"
            platformConstants = libpath -/- "platformConstants"

Andrey Mokhov's avatar
Andrey Mokhov committed
97
        need [settings, platformConstants]
98 99

        pkgName <- getPackageNameFromConfFile conf
100
        let pkg = unsafeFindPackageByName pkgName
Andrey Mokhov's avatar
Andrey Mokhov committed
101
        isBoot <- (pkg `notElem`) <$> stagePackages Stage0
102 103

        let ctx = Context stage pkg vanilla
Andrey Mokhov's avatar
Andrey Mokhov committed
104
        case stage of
105 106
            Stage0 | isBoot -> copyConf  rs ctx conf
            _               -> buildConf rs ctx conf
107 108

buildConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
109
buildConf _ context@Context {..} conf = do
110
    depPkgIds <- cabalDependencies context
111
    ensureConfigured context
112 113 114 115 116
    need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds

    ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
    need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]

117 118
    -- We might need some package-db resource to limit read/write, see packageRules.
    path <- buildPath context
119

120
    -- Special package cases (these should ideally be rolled into Cabal).
121
    when (package == rts) $
122 123 124 125 126
        -- If Cabal knew about "generated-headers", we could read them from the
        -- 'configuredCabal' information, and just "need" them here.
        need [ path -/- "DerivedConstants.h"
             , path -/- "ghcautoconf.h"
             , path -/- "ghcplatform.h"
David Eichmann's avatar
David Eichmann committed
127
             , path -/- "ghcversion.h" ]
128

129
    when (package == integerGmp) $ need [path -/- gmpLibraryH]
130 131

    -- Copy and register the package.
132 133
    Cabal.copyPackage context
    Cabal.registerPackage context
134

135 136 137
    -- The above two steps produce an entry in the package database, with copies
    -- of many of the files we have build, e.g. Haskell interface files. We need
    -- to record this side effect so that Shake can cache these files too.
138
    -- See why we need 'fixWindows': https://gitlab.haskell.org/ghc/ghc/issues/16073
139 140 141 142 143 144 145 146 147 148 149 150
    let fixWindows path = do
            win <- windowsHost
            version  <- setting GhcVersion
            hostOs   <- cabalOsString <$> setting BuildOs
            hostArch <- cabalArchString <$> setting BuildArch
            let dir = hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
            return $ if win then path -/- "../.." -/- dir else path
    pkgDbPath <- fixWindows =<< packageDbPath stage
    let dir = pkgDbPath -/- takeBaseName conf
    files <- liftIO $ getDirectoryFilesIO "." [dir -/- "**"]
    produces files

151 152 153
copyConf :: [(Resource, Int)] -> Context -> FilePath -> Action ()
copyConf rs context@Context {..} conf = do
    depPkgIds <- fmap stdOutToPkgIds . askWithResources rs $
Andrey Mokhov's avatar
Andrey Mokhov committed
154
        target context (GhcPkg Dependencies stage) [pkgName package] []
155
    need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
156 157 158 159
    -- We should unregister if the file exists since @ghc-pkg@ will complain
    -- about existing package: https://github.com/snowleopard/hadrian/issues/543.
    -- Also, we don't always do the unregistration + registration to avoid
    -- repeated work after a full build.
Andrey Mokhov's avatar
Andrey Mokhov committed
160 161 162 163
    -- We do not track 'doesFileExist' since we are going to create the file if
    -- it is currently missing. TODO: Is this the right thing to do?
    -- See https://github.com/snowleopard/hadrian/issues/569.
    unlessM (liftIO $ IO.doesFileExist conf) $ do
164 165 166
        buildWithResources rs $
            target context (GhcPkg Unregister stage) [pkgName package] []
        buildWithResources rs $
167
            target context (GhcPkg Copy stage) [pkgName package] [conf]
168 169 170
  where
    stdOutToPkgIds :: String -> [String]
    stdOutToPkgIds = drop 1 . concatMap words . lines
171 172 173

getPackageNameFromConfFile :: FilePath -> Action String
getPackageNameFromConfFile conf
174 175 176 177 178
    | takeBaseName conf == "rts" = return "rts"
    | otherwise = case parseCabalName (takeBaseName conf) of
        Left err -> error $ "getPackageNameFromConfFile: Couldn't parse " ++
                            takeBaseName conf ++ ": " ++ err
        Right (name, _) -> return name
179

180 181
parseCabalName :: String -> Either String (String, Version)
parseCabalName = fmap f . Cabal.eitherParsec
182
  where
183 184
    f :: Cabal.PackageId -> (String, Version)
    f pkg_id = (Cabal.unPackageName $ Cabal.pkgName pkg_id, Cabal.pkgVersion pkg_id)
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

-- | Return extra library targets.
extraTargets :: Context -> Action [FilePath]
extraTargets context
    | package context == rts  = needRtsLibffiTargets (Context.stage context)
    | otherwise               = return []

-- | Given a library 'Package' this action computes all of its targets. Needing
-- all the targets should build the library such that it is ready to be
-- registered into the package database.
-- See 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
libraryTargets :: Bool -> Context -> Action [FilePath]
libraryTargets includeGhciLib context@Context {..} = do
    libFile  <- pkgLibraryFile     context
    ghciLib  <- pkgGhciLibraryFile context
    ghci     <- if includeGhciLib && not (wayUnit Dynamic way)
                then interpretInContext context $ getContextData buildGhciLib
                else return False
    extra    <- extraTargets context
    return $ [ libFile ]
          ++ [ ghciLib | ghci ]
          ++ extra