{-# LANGUAGE TypeFamilies #-}
module Hadrian.Oracles.Path (
    lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
    ) where

import Control.Monad
import Data.Maybe
import Data.Char
import Data.List.Extra
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import System.Directory
import System.Info.Extra

import Hadrian.Utilities

-- | Lookup a specified 'FilePath' in the system @PATH@.
lookupInPath :: FilePath -> Action FilePath
lookupInPath name
    | name == takeFileName name = askOracle $ LookupInPath name
    | otherwise                 = return name

-- | Lookup the path to the @bash@ interpreter.
bashPath :: Action FilePath
bashPath = lookupInPath "bash"

-- | Fix an absolute path on Windows:
-- * "/c/" => "C:/"
-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
fixAbsolutePathOnWindows :: FilePath -> Action FilePath
fixAbsolutePathOnWindows path =
    if isWindows
    then do
        let (dir, file) = splitFileName path
        winDir <- askOracle $ WindowsPath dir
        return $ winDir -/- file
    else
        return path

newtype LookupInPath = LookupInPath String
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult LookupInPath = String

newtype WindowsPath = WindowsPath FilePath
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult WindowsPath = String

-- | Oracles for looking up paths. These are slow and require caching.
pathOracle :: Rules ()
pathOracle = do
    void $ addOracleCache $ \(WindowsPath path) -> do
        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
        let windowsPath = unifyPath $ dropWhileEnd isSpace out
        putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
        return windowsPath

    void $ addOracleCache $ \(LookupInPath name) -> do
        let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
        path <- unifyPath . unpack <$> liftIO (findExecutable name)
        putLoud $ "| Executable found: " ++ name ++ " => " ++ path
        return path


{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Oracles.TextFile
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Read and parse text files, tracking their contents. This oracle can be used
-- to read configuration or package metadata files and cache the parsing.
-----------------------------------------------------------------------------
module Hadrian.Oracles.TextFile (
    lookupValue, lookupValueOrEmpty, lookupValueOrError, lookupValues,
    lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle
    ) where

import Control.Monad
import qualified Data.HashMap.Strict as Map
import Data.Maybe
import Development.Shake
import Development.Shake.Classes
import Development.Shake.Config

import Hadrian.Utilities

-- | Lookup a value in a text file, tracking the result. Each line of the file
-- is expected to have @key = value@ format.
lookupValue :: FilePath -> String -> Action (Maybe String)
lookupValue file key = askOracle $ KeyValue (file, key)

-- | Like 'lookupValue' but returns the empty string if the key is not found.
lookupValueOrEmpty :: FilePath -> String -> Action String
lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key

-- | Like 'lookupValue' but raises an error if the key is not found.
lookupValueOrError :: FilePath -> String -> Action String
lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key
  where
    msg = "Key " ++ quote key ++ " not found in file " ++ quote file

-- | Lookup a list of values in a text file, tracking the result. Each line of
-- the file is expected to have @key value1 value2 ...@ format.
lookupValues :: FilePath -> String -> Action (Maybe [String])
lookupValues file key = askOracle $ KeyValues (file, key)

-- | Like 'lookupValues' but returns the empty list if the key is not found.
lookupValuesOrEmpty :: FilePath -> String -> Action [String]
lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key

-- | Like 'lookupValues' but raises an error if the key is not found.
lookupValuesOrError :: FilePath -> String -> Action [String]
lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key
  where
    msg = "Key " ++ quote key ++ " not found in file " ++ quote file

-- | The 'Action' @lookupDependencies depFile file@ looks up dependencies of a
-- @file@ in a (typically generated) dependency file @depFile@. The action
-- returns a pair @(source, files)@, such that the @file@ can be produced by
-- compiling @source@, which in turn also depends on a number of other @files@.
lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath])
lookupDependencies depFile file = do
    deps <- lookupValues depFile file
    case deps of
        Nothing -> error $ "No dependencies found for file " ++ quote file
        Just [] -> error $ "No source file found for file " ++ quote file
        Just (source : files) -> return (source, files)

newtype KeyValue = KeyValue (FilePath, String)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult KeyValue = Maybe String

newtype KeyValues = KeyValues (FilePath, String)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult KeyValues = Maybe [String]

-- | These oracle rules are used to cache and track answers to the following
-- queries, which are implemented by parsing text files:
--
-- 1) Looking up key-value pairs formatted as @key = value1 value2 ...@ that
--    are often used in text configuration files. See functions 'lookupValue',
--    'lookupValueOrEmpty', 'lookupValueOrError', 'lookupValues',
--    'lookupValuesOrEmpty' and 'lookupValuesOrError'.
--
-- 2) Parsing Makefile dependecy files generated by commands like @gcc -MM@:
--    see 'lookupDependencies'.
textFileOracle :: Rules ()
textFileOracle = do
    kv <- newCache $ \file -> do
        need [file]
        putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..."
        liftIO $ readConfigFile file
    void $ addOracleCache $ \(KeyValue (file, key)) -> Map.lookup key <$> kv file

    kvs <- newCache $ \file -> do
        need [file]
        putLoud $ "| KeyValues oracle: reading " ++ quote file ++ "..."
        contents <- map words <$> readFileLines file
        return $ Map.fromList [ (key, values) | (key:values) <- contents ]
    void $ addOracleCache $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Oracles.Cabal.Rules
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- This module defines Shake rules corresponing to the /Cabal oracle/; see
-- the module "Hadrian.Oracles.Cabal" for various supported queries.
-----------------------------------------------------------------------------
module Hadrian.Oracles.Cabal.Rules where

import Control.Monad
import Data.Maybe
import Development.Shake
import Distribution.Simple.GHC
import Distribution.Simple.Program.Db
import Distribution.Verbosity

import Builder
import Context
import Hadrian.Haskell.Cabal.Parse
import Hadrian.Oracles.Cabal.Type
import Hadrian.Package
import Hadrian.Utilities

-- | These oracle rules are used to cache and track answers to the following
-- queries, which are implemented via the Cabal library:
--
-- 1) 'Hadrian.Oracles.Cabal.readPackageData' that reads Cabal package data.
--
-- 2) 'Hadrian.Oracles.Cabal.readContextData' that reads 'Context'-dependent
--    Cabal package data.
--
-- 3) 'Hadrian.Oracles.Cabal.configurePackageGHC' that configures a package.
cabalOracle :: Rules ()
cabalOracle = do
    void $ addOracleCache $ \(PackageDataKey package) -> do
        let file = pkgCabalFile package
        need [file]
        putLoud $ "| PackageData oracle: parsing " ++ quote file ++ "..."
        parsePackageData package

    void $ addOracleCache $ \(ContextDataKey context@Context {..}) -> do
        putLoud $ "| ContextData oracle: resolving data for "
               ++ quote (pkgName package) ++ " (" ++ show stage
               ++ ", " ++ show way ++ ")..."
        -- Calling 'need' on @setup-config@ triggers 'configurePackage'. Why
        -- this indirection? Going via @setup-config@ allows us to cache the
        -- configuration step, i.e. not to repeat it if it's already been done.
        setupConfig <- pkgSetupConfigFile context
        need [setupConfig]
        resolveContextData context

    void $ addOracleCache $ \(PackageConfigurationKey (pkg, stage)) -> do
        putLoud $ "| PackageConfiguration oracle: configuring "
               ++ quote (pkgName pkg) ++ " (" ++ show stage ++ ")..."
        -- Configure the package with the GHC corresponding to the given stage
        hcPath <- builderPath (Ghc CompileHs stage)
        (compiler, maybePlatform, _pkgdb) <- liftIO $
            configure silent (Just hcPath) Nothing emptyProgramDb
        let platform = fromMaybe (error msg) maybePlatform
            msg      = "PackageConfiguration oracle: cannot detect platform"
        return $ PackageConfiguration (compiler, platform)


{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Oracles.Cabal.Type
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- This module defines the types of keys used by the /Cabal oracles/. See the
-- module "Hadrian.Oracles.Cabal" for supported Cabal oracle queries, and the
-- module "Hadrian.Oracles.Cabal.Rules" for the corresponing Shake rules.
-----------------------------------------------------------------------------
module Hadrian.Oracles.Cabal.Type where

import Development.Shake
import Development.Shake.Classes
import qualified Distribution.Simple as C
import qualified Distribution.System as C

import Context.Type
import Hadrian.Haskell.Cabal.Type
import Hadrian.Package
import Stage

-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.readPackageData'
-- to cache reading and parsing of 'Hadrian.Haskell.Cabal.Type.PackageData'.
newtype PackageDataKey = PackageDataKey Package
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult PackageDataKey = PackageData

-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.readContextData'
-- to cache reading and parsing of 'Hadrian.Haskell.Cabal.Type.ContextData'.
newtype ContextDataKey = ContextDataKey Context
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult ContextDataKey = ContextData

-- TODO: Should @PackageConfiguration@ be simply @()@? Presumably the pair
-- @(Compiler, Maybe Platform)@ is fully determined by the current build Stage.
-- | The result of Cabal package configuration produced by the oracle
-- 'Hadrian.Oracles.Cabal.configurePackageGHC'.
newtype PackageConfiguration = PackageConfiguration (C.Compiler, C.Platform)
    deriving (Binary, Eq, Show, Typeable)

instance NFData PackageConfiguration where
    rnf (PackageConfiguration (c, p)) =
        rnf (C.compilerId c)                      `seq`
        rnf (C.abiTagString $ C.compilerAbiTag c) `seq`
        rnf (C.compilerCompat c)                  `seq`
        rnf (C.compilerLanguages c)               `seq`
        rnf (C.compilerExtensions c)              `seq`
        rnf (C.compilerProperties c)              `seq`
        rnf p

instance Hashable PackageConfiguration where
    hashWithSalt _ = hash . show

-- | This type of oracle key is used by 'Hadrian.Oracles.Cabal.configurePackageGHC'
-- to cache configuration of a Cabal package.
newtype PackageConfigurationKey = PackageConfigurationKey (Package, Stage)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult PackageConfigurationKey = PackageConfiguration


module Oracles.Flag (
    Flag (..), flag, getFlag, platformSupportsSharedLibs, ghcWithSMP,
    ghcWithNativeCodeGen
    ) where

import Hadrian.Oracles.TextFile
import Hadrian.Expression

import Base
import Oracles.Setting

data Flag = ArSupportsAtFile
          | CrossCompiling
          | GccIsClang
          | GhcUnregisterised
          | GmpInTree
          | GmpFrameworkPref
          | LeadingUnderscore
          | SolarisBrokenShld
          | WithLibdw
          | HaveLibMingwEx
          | UseSystemFfi

-- Note, if a flag is set to empty string we treat it as set to NO. This seems
-- fragile, but some flags do behave like this, e.g. GccIsClang.
flag :: Flag -> Action Bool
flag f = do
    let key = case f of
            ArSupportsAtFile   -> "ar-supports-at-file"
            CrossCompiling     -> "cross-compiling"
            GccIsClang         -> "gcc-is-clang"
            GhcUnregisterised  -> "ghc-unregisterised"
            GmpInTree          -> "intree-gmp"
            GmpFrameworkPref   -> "gmp-framework-preferred"
            LeadingUnderscore  -> "leading-underscore"
            SolarisBrokenShld  -> "solaris-broken-shld"
            WithLibdw          -> "with-libdw"
            HaveLibMingwEx     -> "have-lib-mingw-ex"
            UseSystemFfi       -> "use-system-ffi"
    value <- lookupValueOrError configFile key
    when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
        ++ quote (key ++ " = " ++ value) ++ " cannot be parsed."
    return $ value == "YES"

-- | Get a configuration setting.
getFlag :: Flag -> Expr c b Bool
getFlag = expr . flag

platformSupportsSharedLibs :: Action Bool
platformSupportsSharedLibs = do
    badPlatform   <- anyTargetPlatform [ "powerpc-unknown-linux"
                                       , "x86_64-unknown-mingw32"
                                       , "i386-unknown-mingw32" ]
    solaris       <- anyTargetPlatform [ "i386-unknown-solaris2" ]
    solarisBroken <- flag SolarisBrokenShld
    return $ not (badPlatform || solaris && solarisBroken)

ghcWithSMP :: Action Bool
ghcWithSMP = do
    goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc", "arm"]
    ghcUnreg <- flag GhcUnregisterised
    return $ goodArch && not ghcUnreg

ghcWithNativeCodeGen :: Action Bool
ghcWithNativeCodeGen = do
    goodArch <- anyTargetArch ["i386", "x86_64", "sparc", "powerpc"]
    badOs    <- anyTargetOs ["ios", "aix"]
    ghcUnreg <- flag GhcUnregisterised
    return $ goodArch && not badOs && not ghcUnreg


{-# LANGUAGE TypeFamilies #-}
module Oracles.ModuleFiles (
    decodeModule, encodeModule, findGenerator, hsSources, hsObjects,
    moduleFilesOracle
    ) where

import qualified Data.HashMap.Strict as Map
import Hadrian.Haskell.Cabal.Type as PD

import Base
import Builder
import Context
import Expression
import Packages

type ModuleName = String

newtype ModuleFiles = ModuleFiles (Stage, Package)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult ModuleFiles = [Maybe FilePath]

newtype Generator = Generator (Stage, Package, FilePath)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult Generator = Maybe FilePath

-- | We scan for the following Haskell source extensions when looking for module
-- files. Note, we do not list "*.(l)hs-boot" files here, as they can never
-- appear by themselves and always have accompanying "*.(l)hs" master files.
haskellExtensions :: [String]
haskellExtensions = [".hs", ".lhs"]

-- | Non-Haskell source extensions and corresponding builders.
otherExtensions :: Stage -> [(String, Builder)]
otherExtensions stage = [ (".x"  , Alex  )
                        , (".y"  , Happy )
                        , (".ly" , Happy )
                        , (".hsc", Hsc2Hs stage) ]

-- | We match the following file patterns when looking for module files.
moduleFilePatterns :: Stage -> [FilePattern]
moduleFilePatterns stage = map ("*" ++) $ haskellExtensions ++ map fst (otherExtensions stage)

-- | Given a FilePath determine the corresponding builder.
determineBuilder :: Stage -> FilePath -> Maybe Builder
determineBuilder stage file = lookup (takeExtension file) (otherExtensions stage)

-- | Given a non-empty module name extract the directory and file name, e.g.:
--
-- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
-- > decodeModule "Prelude"               == ("", "Prelude")
decodeModule :: ModuleName -> (FilePath, String)
decodeModule moduleName = (intercalate "/" (init xs), last xs)
  where
    xs = words $ replaceEq '.' ' ' moduleName

-- | Given the directory and file name find the corresponding module name, e.g.:
--
-- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
-- > encodeModule "" "Prelude"                 == "Prelude"
-- > uncurry encodeModule (decodeModule name)  == name
encodeModule :: FilePath -> String -> ModuleName
encodeModule dir file
    | dir == "" =                                takeBaseName file
    | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file

-- | Find the generator for a given 'Context' and a source file. For example:
-- findGenerator (Context Stage1 compiler vanilla)
--               "_build/stage1/compiler/build/Lexer.hs"
-- == Just ("compiler/parser/Lexer.x", Alex)
-- findGenerator (Context Stage1 base vanilla)
--               "_build/stage1/base/build/Prelude.hs"
-- == Nothing
findGenerator :: Context -> FilePath -> Action (Maybe (FilePath, Builder))
findGenerator Context {..} file = do
    maybeSource <- askOracle $ Generator (stage, package, file)
    return $ do
        source  <- maybeSource
        builder <- determineBuilder stage source
        return (source, builder)

-- | Find all Haskell source files for a given 'Context'.
hsSources :: Context -> Action [FilePath]
hsSources context = do
    let modFile (m, Nothing)
            | "Paths_" `isPrefixOf` m = autogenFile context m
            | otherwise               = generatedFile context m
        modFile (m, Just file )
            | takeExtension file `elem` haskellExtensions = return file
            | otherwise = generatedFile context m
    mapM modFile =<< contextFiles context

-- | Find all Haskell object files for a given 'Context'. Note: this is a much
-- simpler function compared to 'hsSources', because all object files live in
-- the build directory regardless of whether they are generated or not.
hsObjects :: Context -> Action [FilePath]
hsObjects context = do
    modules <- interpretInContext context (getContextData PD.modules)
    mapM (objectPath context . moduleSource) modules

-- | Generated module files live in the 'Context' specific build directory.
generatedFile :: Context -> ModuleName -> Action FilePath
generatedFile context moduleName = buildPath context <&> (-/- moduleSource moduleName)

-- | Generated module files live in the 'Context' specific build directory.
autogenFile :: Context -> ModuleName -> Action FilePath
autogenFile context modName = autogenPath context <&> (-/- moduleSource modName)

-- | Turn a module name (e.g. @Data.Functor@) to a path (e.g. @Data/Functor.hs@).
moduleSource :: ModuleName -> FilePath
moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"

-- | Module files for a given 'Context'.
contextFiles :: Context -> Action [(ModuleName, Maybe FilePath)]
contextFiles context@Context {..} = do
    modules <- fmap sort . interpretInContext context $
        getContextData PD.modules
    zip modules <$> askOracle (ModuleFiles (stage, package))

-- | This is an important oracle whose role is to find and cache module source
-- files. It takes a 'Stage' and a 'Package', looks up corresponding source
-- directories @dirs@ and a sorted list of module names @modules@, and for each
-- module, e.g. @A.B.C@, returns a 'FilePath' of the form @dir/A/B/C.extension@,
-- such that @dir@ belongs to @dirs@, and file @dir/A/B/C.extension@ exists, or
-- 'Nothing' if there is no such file. If more than one matching file is found
-- an error is raised. For example, for 'Stage1' and 'compiler', @dirs@ will
-- contain ["compiler/codeGen", "compiler/parser"], and @modules@ will contain
-- ["CodeGen.Platform.ARM", "Config", "Lexer"]; the oracle will produce a list
-- containing [Just "compiler/codeGen/CodeGen/Platform/ARM.hs", Nothing,
-- Just "compiler/parser/Lexer.x"]. The oracle ignores @.(l)hs-boot@ files.
moduleFilesOracle :: Rules ()
moduleFilesOracle = void $ do
    void . addOracleCache $ \(ModuleFiles (stage, package)) -> do
        let context = vanillaContext stage package
        ensureConfigured context
        srcDirs <- interpretInContext context (getContextData PD.srcDirs)
        mainIs  <- interpretInContext context (getContextData PD.mainIs)
        let removeMain = case mainIs of
                              Just (mod, _) -> delete mod
                              Nothing       -> id
        modules <- fmap sort $ interpretInContext context (getContextData PD.modules)
        autogen <- autogenPath context
        let dirs = autogen : map (pkgPath package -/-) srcDirs
            -- Don't resolve the file path for module `Main` twice.
            modDirFiles = groupSort $ map decodeModule $ removeMain modules
        result <- concatForM dirs $ \dir -> do
            todo <- filterM (doesDirectoryExist . (dir -/-) . fst) modDirFiles
            forM todo $ \(mDir, mFiles) -> do
                let fullDir = unifyPath $ dir -/- mDir
                files <- getDirectoryFiles fullDir (moduleFilePatterns stage)
                let cmp f = compare (dropExtension f)
                    found = intersectOrd cmp files mFiles
                return (map (fullDir -/-) found, mDir)

        -- For a BuildInfo, it may be a library, which doesn't have the @Main@
        -- module, or an executable, which must have the @Main@ module and the
        -- file path of @Main@ module is indicated by the @main-is@ field in its
        -- Cabal file.
        --
        -- For the Main module, the file name may not be @Main.hs@, unlike other
        -- exposed modules. We could get the file path by the module name for
        -- other exposed modules, but for @Main@ we must resolve the file path
        -- via the @main-is@ field in the Cabal file.
        mainpairs <- case mainIs of
            Just (mod, filepath) ->
                concatForM dirs $ \dir -> do
                    found <- doesFileExist (dir -/- filepath)
                    return [(mod, unifyPath $ dir -/- filepath) | found]
            Nothing -> return []

        let pairs = sort $ mainpairs ++ [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
            multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
        unless (null multi) $ do
            let (m, f1, f2) = head multi
            error $ "Module " ++ m ++ " has more than one source file: "
                ++ f1 ++ " and " ++ f2 ++ "."
        return $ lookupAll modules pairs

    -- Optimisation: we discard Haskell files here, because they are never used
    -- as generators, and hence would be discarded in 'findGenerator' anyway.
    generators <- newCache $ \(stage, package) -> do
        let context = vanillaContext stage package
        files <- contextFiles context
        list  <- sequence [ (,src) <$> generatedFile context modName
                          | (modName, Just src) <- files
                          , takeExtension src `notElem` haskellExtensions ]
        return $ Map.fromList list

    addOracleCache $ \(Generator (stage, package, file)) ->
        Map.lookup file <$> generators (stage, package)


module Oracles.Setting (
    configFile, Setting (..), SettingList (..), setting, settingList, getSetting,
    getSettingList,  anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs,
    ghcWithInterpreter, ghcEnableTablesNextToCode, useLibFFIForAdjustors,
    ghcCanonVersion, cmdLineLengthLimit, iosHost, osxHost, windowsHost,
    hostSupportsRPaths, topDirectory, libsuf
    ) where

import Hadrian.Expression
import Hadrian.Oracles.TextFile
import Hadrian.Oracles.Path

import Base

-- | Each 'Setting' comes from the file @hadrian/cfg/system.config@, generated
-- by the @configure@ script from the input file @hadrian/cfg/system.config.in@.
-- For example, the line
--
-- > target-os = mingw32
--
-- sets the value of the setting 'TargetOs'. The action 'setting' 'TargetOs'
-- looks up the value of the setting and returns the string @"mingw32"@,
-- tracking the result in the Shake database.
data Setting = BuildArch
             | BuildOs
             | BuildPlatform
             | BuildVendor
             | CcClangBackend
             | CcLlvmBackend
             | CursesLibDir
             | DynamicExtension
             | FfiIncludeDir
             | FfiLibDir
             | GhcMajorVersion
             | GhcMinorVersion
             | GhcPatchLevel
             | GhcVersion
             | GhcSourcePath
             | GmpIncludeDir
             | GmpLibDir
             | HostArch
             | HostOs
             | HostPlatform
             | HostVendor
             | IconvIncludeDir
             | IconvLibDir
             | LlvmTarget
             | ProjectGitCommitId
             | ProjectName
             | ProjectVersion
             | ProjectVersionInt
             | ProjectPatchLevel
             | ProjectPatchLevel1
             | ProjectPatchLevel2
             | SystemGhc
             | TargetArch
             | TargetOs
             | TargetPlatform
             | TargetPlatformFull
             | TargetVendor

-- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions).
-- | Each 'SettingList' comes from the file @hadrian/cfg/system.config@,
-- generated by the @configure@ script from the input file
-- @hadrian/cfg/system.config.in@. For example, the line
--
-- > hs-cpp-args = -E -undef -traditional
--
-- sets the value of 'HsCppArgs'. The action 'settingList' 'HsCppArgs' looks up
-- the value of the setting and returns the list of strings
-- @["-E", "-undef", "-traditional"]@, tracking the result in the Shake database.
data SettingList = ConfCcArgs Stage
                 | ConfCppArgs Stage
                 | ConfGccLinkerArgs Stage
                 | ConfLdLinkerArgs Stage
                 | HsCppArgs

-- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the
-- result.
setting :: Setting -> Action String
setting key = lookupValueOrError configFile $ case key of
    BuildArch          -> "build-arch"
    BuildOs            -> "build-os"
    BuildPlatform      -> "build-platform"
    BuildVendor        -> "build-vendor"
    CcClangBackend     -> "cc-clang-backend"
    CcLlvmBackend      -> "cc-llvm-backend"
    CursesLibDir       -> "curses-lib-dir"
    DynamicExtension   -> "dynamic-extension"
    FfiIncludeDir      -> "ffi-include-dir"
    FfiLibDir          -> "ffi-lib-dir"
    GhcMajorVersion    -> "ghc-major-version"
    GhcMinorVersion    -> "ghc-minor-version"
    GhcPatchLevel      -> "ghc-patch-level"
    GhcVersion         -> "ghc-version"
    GhcSourcePath      -> "ghc-source-path"
    GmpIncludeDir      -> "gmp-include-dir"
    GmpLibDir          -> "gmp-lib-dir"
    HostArch           -> "host-arch"
    HostOs             -> "host-os"
    HostPlatform       -> "host-platform"
    HostVendor         -> "host-vendor"
    IconvIncludeDir    -> "iconv-include-dir"
    IconvLibDir        -> "iconv-lib-dir"
    LlvmTarget         -> "llvm-target"
    ProjectGitCommitId -> "project-git-commit-id"
    ProjectName        -> "project-name"
    ProjectVersion     -> "project-version"
    ProjectVersionInt  -> "project-version-int"
    ProjectPatchLevel  -> "project-patch-level"
    ProjectPatchLevel1 -> "project-patch-level1"
    ProjectPatchLevel2 -> "project-patch-level2"
    SystemGhc          -> "system-ghc"
    TargetArch         -> "target-arch"
    TargetOs           -> "target-os"
    TargetPlatform     -> "target-platform"
    TargetPlatformFull -> "target-platform-full"
    TargetVendor       -> "target-vendor"

-- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the
-- result.
settingList :: SettingList -> Action [String]
settingList key = fmap words $ lookupValueOrError configFile $ case key of
    ConfCcArgs        stage -> "conf-cc-args-"         ++ stageString stage
    ConfCppArgs       stage -> "conf-cpp-args-"        ++ stageString stage
    ConfGccLinkerArgs stage -> "conf-gcc-linker-args-" ++ stageString stage
    ConfLdLinkerArgs  stage -> "conf-ld-linker-args-"  ++ stageString stage
    HsCppArgs               -> "hs-cpp-args"

-- | An expression that looks up the value of a 'Setting' in @cfg/system.config@,
-- tracking the result.
getSetting :: Setting -> Expr c b String
getSetting = expr . setting

-- | An expression that looks up the value of a 'SettingList' in
-- @cfg/system.config@, tracking the result.
getSettingList :: SettingList -> Args c b
getSettingList = expr . settingList

-- | Check whether the value of a 'Setting' matches one of the given strings.
matchSetting :: Setting -> [String] -> Action Bool
matchSetting key values = (`elem` values) <$> setting key

-- | Check whether the target platform setting matches one of the given strings.
anyTargetPlatform :: [String] -> Action Bool
anyTargetPlatform = matchSetting TargetPlatformFull

-- | Check whether the target OS setting matches one of the given strings.
anyTargetOs :: [String] -> Action Bool
anyTargetOs = matchSetting TargetOs

-- | Check whether the target architecture setting matches one of the given
-- strings.
anyTargetArch :: [String] -> Action Bool
anyTargetArch = matchSetting TargetArch

-- | Check whether the host OS setting matches one of the given strings.
anyHostOs :: [String] -> Action Bool
anyHostOs = matchSetting HostOs

-- | Check whether the host OS setting is set to @"ios"@.
iosHost :: Action Bool
iosHost = anyHostOs ["ios"]

-- | Check whether the host OS setting is set to @"darwin"@.
osxHost :: Action Bool
osxHost = anyHostOs ["darwin"]

-- | Check whether the host OS supports the @-rpath@ linker option when
-- using dynamic linking.
--
-- TODO: Windows supports lazy binding (but GHC doesn't currently support
--       dynamic way on Windows anyways).
hostSupportsRPaths :: Action Bool
hostSupportsRPaths = anyHostOs ["linux", "darwin", "freebsd"]

-- | Check whether the host OS setting is set to @"mingw32"@ or @"cygwin32"@.
windowsHost :: Action Bool
windowsHost = anyHostOs ["mingw32", "cygwin32"]

-- | Check whether the target supports GHCi.
ghcWithInterpreter :: Action Bool
ghcWithInterpreter = do
    goodOs <- anyTargetOs [ "mingw32", "cygwin32", "linux", "solaris2"
                          , "freebsd", "dragonfly", "netbsd", "openbsd"
                          , "darwin", "kfreebsdgnu" ]
    goodArch <- anyTargetArch [ "i386", "x86_64", "powerpc", "sparc"
                              , "sparc64", "arm" ]
    return $ goodOs && goodArch

-- | Check whether the target architecture supports placing info tables next to
-- code. See: https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/HeapObjects#TABLES_NEXT_TO_CODE.
ghcEnableTablesNextToCode :: Action Bool
ghcEnableTablesNextToCode = notM $ anyTargetArch ["ia64", "powerpc64", "powerpc64le"]

-- | Check to use @libffi@ for adjustors.
useLibFFIForAdjustors :: Action Bool
useLibFFIForAdjustors = notM $ anyTargetArch ["i386", "x86_64"]

-- | Canonicalised GHC version number, used for integer version comparisons. We
-- expand 'GhcMinorVersion' to two digits by adding a leading zero if necessary.
ghcCanonVersion :: Action String
ghcCanonVersion = do
    ghcMajorVersion <- setting GhcMajorVersion
    ghcMinorVersion <- setting GhcMinorVersion
    let leadingZero = [ '0' | length ghcMinorVersion == 1 ]
    return $ ghcMajorVersion ++ leadingZero ++ ghcMinorVersion

-- | Path to the GHC source tree.
topDirectory :: Action FilePath
topDirectory = fixAbsolutePathOnWindows =<< setting GhcSourcePath

-- | The file suffix used for libraries of a given build 'Way'. For example,
-- @_p.a@ corresponds to a static profiled library, and @-ghc7.11.20141222.so@
-- is a dynamic vanilly library. Why do we need GHC version number in the
-- dynamic suffix? Here is a possible reason: dynamic libraries are placed in a
-- single giant directory in the load path of the dynamic linker, and hence we
-- must distinguish different versions of GHC. In contrast, static libraries
-- live in their own per-package directory and hence do not need a unique
-- filename. We also need to respect the system's dynamic extension, e.g. @.dll@
-- or @.so@.
libsuf :: Way -> Action String
libsuf way
    | not (wayUnit Dynamic way) = return (waySuffix way ++ ".a") -- e.g., _p.a
    | otherwise = do
        extension <- setting DynamicExtension -- e.g., .dll or .so
        version   <- setting ProjectVersion   -- e.g., 7.11.20141222
        let suffix = waySuffix (removeWayUnit Dynamic way)
        return (suffix ++ "-ghc" ++ version ++ extension)


-- | We create a file <root>/test/ghcconfig containing configuration of test
-- | compiler. We need to search this file for required keys and setting
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc.

module Oracles.TestSettings (TestSetting (..), testSetting, testRTSSettings) where

import Base
import Hadrian.Oracles.TextFile

testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")

-- | Test settings that are obtained from ghcconfig file.
data TestSetting = TestHostOS
                 | TestWORDSIZE
                 | TestTARGETPLATFORM
                 | TestTargetOS_CPP
                 | TestTargetARCH_CPP
                 | TestGhcStage
                 | TestGhcDebugged
                 | TestGhcWithNativeCodeGen
                 | TestGhcWithInterpreter
                 | TestGhcUnregisterised
                 | TestGhcWithSMP
                 | TestGhcDynamicByDefault
                 | TestGhcDynamic
                 | TestGhcProfiled
                 | TestAR
                 | TestCLANG
                 | TestLLC
                 | TestTEST_CC
                 | TestGhcPackageDbFlag
                 | TestMinGhcVersion711
                 | TestMinGhcVersion801
                 deriving (Show)

-- | Lookup a test setting in @ghcconfig@ file.
-- | To obtain RTS ways supported in @ghcconfig@ file, use 'testRTSSettings'.
testSetting :: TestSetting -> Action String
testSetting key = do
    file <- testConfigFile
    lookupValueOrError file $ case key of
        TestHostOS                -> "HostOS"
        TestWORDSIZE              -> "WORDSIZE"
        TestTARGETPLATFORM        -> "TARGETPLATFORM"
        TestTargetOS_CPP          -> "TargetOS_CPP"
        TestTargetARCH_CPP        -> "TargetARCH_CPP"
        TestGhcStage              -> "GhcStage"
        TestGhcDebugged           -> "GhcDebugged"
        TestGhcWithNativeCodeGen  -> "GhcWithNativeCodeGen"
        TestGhcWithInterpreter    -> "GhcWithInterpreter"
        TestGhcUnregisterised     -> "GhcUnregisterised"
        TestGhcWithSMP            -> "GhcWithSMP"
        TestGhcDynamicByDefault   -> "GhcDynamicByDefault"
        TestGhcDynamic            -> "GhcDynamic"
        TestGhcProfiled           -> "GhcProfiled"
        TestAR                    -> "AR"
        TestCLANG                 -> "CLANG"
        TestLLC                   -> "LLC"
        TestTEST_CC               -> "TEST_CC"
        TestGhcPackageDbFlag      -> "GhcPackageDbFlag"
        TestMinGhcVersion711      -> "MinGhcVersion711"
        TestMinGhcVersion801      -> "MinGhcVersion801"

-- | Get the RTS ways of the test compiler
testRTSSettings :: Action [String]
testRTSSettings = do
    file <- testConfigFile
    words <$> lookupValueOrError file "GhcRTSWays"


module Rules.BinaryDist where

import Hadrian.Haskell.Cabal

import Context
import Expression
import Oracles.Setting
import Packages
import Settings
import Target
import Utilities

{-
Note [Binary distributions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~

Hadrian produces binary distributions under:
  <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz

It is generated by creating an archive from:
  <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/

It does so by following the steps below.

- make sure we have a complete stage 2 compiler + haddock

- copy the bin and lib directories of the compiler we built:
    <build root>/stage1/{bin, lib}
  to
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/{bin, lib}

- copy the generated docs (user guide, haddocks, etc):
    <build root>/docs/
  to
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/docs/

- copy haddock (built by our stage2 compiler):
    <build root>/stage2/bin/haddock
  to
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/bin/haddock

- use autoreconf to generate a `configure` script from
  aclocal.m4 and distrib/configure.ac, that we move to:
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/configure

- write a (fixed) Makefile capable of supporting 'make install' to:
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/Makefile

- write some (fixed) supporting bash code for the wrapper scripts to:
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/wrappers/<program>

  where <program> is the name of the executable that the bash file will
  help wrapping.

- copy supporting configure/make related files
  (see @bindistInstallFiles@) to:
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/<file>

- create a .tar.xz archive of the directory:
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>/
  at
    <build root>/bindist/ghc-<X>.<Y>.<Z>-<arch>-<os>.tar.xz

Note [Wrapper scripts and binary distributions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Users of Linux, FreeBSD, Windows and OS X can unpack a
binary distribution produced by hadrian for their arch
and OS and start using @bin/ghc@, @bin/ghc-pkg@ and so on
right away, without even having to configure or install
the distribution. They would then be using the real executables
directly, not through wrapper scripts.

This works because GHCs produced by hadrian on those systems
are relocatable. This means that you can copy the @bin@ and @lib@
dirs anywhere and GHC will keep working, as long as both
directories sit next to each other. (This is achieved by having
GHC look up its $libdir relatively to where the GHC executable
resides.)

It is however still possible (and simple) to install a GHC
distribution that uses wrapper scripts. From the unpacked archive,
you can simply do:

  ./configure --prefix=<path> [... other configure options ...]
  make install

-}

bindistRules :: Rules ()
bindistRules = do
    root <- buildRootRules
    phony "binary-dist" $ do
        -- We 'need' all binaries and libraries
        targets <- mapM pkgTarget =<< stagePackages Stage1
        need targets

        version        <- setting ProjectVersion
        targetPlatform <- setting TargetPlatformFull
        distDir        <- Context.distDir
        rtsDir         <- pkgIdentifier rts
        windows        <- windowsHost

        let ghcBuildDir      = root -/- stageString Stage1
            bindistFilesDir  = root -/- "bindist" -/- ghcVersionPretty
            ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform
            rtsIncludeDir    = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
                               -/- "include"

        -- We create the bindist directory at <root>/bindist/ghc-X.Y.Z-platform/
        -- and populate it with Stage2 build results
        createDirectory bindistFilesDir
        copyDirectory (ghcBuildDir -/- "bin") bindistFilesDir
        copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir
        copyDirectory (rtsIncludeDir)         bindistFilesDir
        need ["docs"]
        copyDirectory (root -/- "docs") bindistFilesDir
        when windows $ do
          copyDirectory (root -/- "mingw") bindistFilesDir
          -- we use that opportunity to delete the .stamp file that we use
          -- as a proxy for the whole mingw toolchain, there's no point in
          -- shipping it
          removeFile (bindistFilesDir -/- mingwStamp)

        -- We copy the binary (<build root>/stage1/bin/haddock) to
        -- the bindist's bindir (<build root>/bindist/ghc-.../bin/).
        haddockPath <- programPath (vanillaContext Stage1 haddock)
        copyFile haddockPath (bindistFilesDir -/- "bin" -/- "haddock")

        -- We then 'need' all the files necessary to configure and install
        -- (as in, './configure [...] && make install') this build on some
        -- other machine.
        need $ map (bindistFilesDir -/-)
                   (["configure", "Makefile"] ++ bindistInstallFiles)
        need $ map ((bindistFilesDir -/- "wrappers") -/-) ["check-api-annotations"
                   , "check-ppr", "ghc", "ghc-iserv", "ghc-pkg"
                   , "ghci-script", "ghci", "haddock", "hpc", "hp2ps", "hsc2hs"
                   , "runghc"]

        -- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz
        tarPath <- builderPath (Tar Create)
        cmd [Cwd $ root -/- "bindist"] tarPath
            [ "-c", "--xz", "-f"
            , ghcVersionPretty <.> "tar.xz"
            , ghcVersionPretty ]

    -- Prepare binary distribution configure script
    -- (generated under <ghc root>/distrib/configure by 'autoreconf')
    root -/- "bindist" -/- "ghc-*" -/- "configure" %> \configurePath -> do
        ghcRoot <- topDirectory
        copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4")
        buildWithCmdOptions [] $
            target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] []
        -- We clean after ourselves, moving the configure script we generated in
        -- our bindist dir
        removeFile (ghcRoot -/- "distrib" -/- "aclocal.m4")
        moveFile (ghcRoot -/- "distrib" -/- "configure") configurePath

    -- Generate the Makefile that enables the "make install" part
    root -/- "bindist" -/- "ghc-*" -/- "Makefile" %> \makefilePath ->
        writeFile' makefilePath bindistMakefile

    root -/- "bindist" -/- "ghc-*" -/- "wrappers/*" %> \wrapperPath ->
        writeFile' wrapperPath $ wrapper (takeFileName wrapperPath)

    -- Copy various configure-related files needed for a working
    -- './configure [...] && make install' workflow
    -- (see the list of files needed in the 'binary-dist' rule above, before
    -- creating the archive).
    forM_ bindistInstallFiles $ \file ->
        root -/- "bindist" -/- "ghc-*" -/- file %> \dest -> do
            ghcRoot <- topDirectory
            copyFile (ghcRoot -/- fixup file) dest

  where
    fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f
            | otherwise                      = f

-- | A list of files that allow us to support a simple
-- @./configure [...] && make install@ workflow.
bindistInstallFiles :: [FilePath]
bindistInstallFiles =
    [ "config.sub", "config.guess", "install-sh", "mk" -/- "config.mk.in"
    , "mk" -/- "install.mk.in", "mk" -/- "project.mk", "settings.in", "README"
    , "INSTALL" ]

-- | This auxiliary function gives us a top-level 'Filepath' that we can 'need'
-- for all libraries and programs that are needed for a complete build.
-- For libraries, it returns the path to the @.conf@ file in the package
-- database. For programs, it returns the path to the compiled executable.
pkgTarget :: Package -> Action FilePath
pkgTarget pkg
    | isLibrary pkg = pkgConfFile (vanillaContext Stage1 pkg)
    | otherwise     = programPath =<< programContext Stage1 pkg

-- TODO: Augment this Makefile to match the various parameters that the current
-- bindist scripts support.
-- | A trivial Makefile that only takes @$prefix@ into account, and not e.g
-- @$datadir@ (for docs) and other variables, yet.
bindistMakefile :: String
bindistMakefile = unlines
    [ "MAKEFLAGS += --no-builtin-rules"
    , ".SUFFIXES:"
    , ""
    , "include mk/install.mk"
    , "include mk/config.mk"
    , ""
    , ".PHONY: default"
    , "default:"
    , "\t@echo 'Run \"make install\" to install'"
    , "\t@false"
    , ""
    , "#-----------------------------------------------------------------------"
    , "# INSTALL RULES"
    , ""
    , "# Hacky function to check equality of two strings"
    , "# TODO : find if a better function exists"
    , "eq=$(and $(findstring $(1),$(2)),$(findstring $(2),$(1)))"
    , ""
    , "define installscript"
    , "# $1 = package name"
    , "# $2 = wrapper path"
    , "# $3 = bindir"
    , "# $4 = ghcbindir"
    , "# $5 = Executable binary path"
    , "# $6 = Library Directory"
    , "# $7 = Docs Directory"
    , "# $8 = Includes Directory"
    , "# We are installing wrappers to programs by searching corresponding"
    , "# wrappers. If wrapper is not found, we are attaching the common wrapper"
    , "# to it. This implementation is a bit hacky and depends on consistency"
    , "# of program names. For hadrian build this will work as programs have a"
    , "# consistent naming procedure."
    , "\trm -f '$2'"
    , "\t$(CREATE_SCRIPT) '$2'"
    , "\t@echo \"#!$(SHELL)\" >>  '$2'"
    , "\t@echo \"exedir=\\\"$4\\\"\" >> '$2'"
    , "\t@echo \"exeprog=\\\"$1\\\"\" >> '$2'"
    , "\t@echo \"executablename=\\\"$5\\\"\" >> '$2'"
    , "\t@echo \"bindir=\\\"$3\\\"\" >> '$2'"
    , "\t@echo \"libdir=\\\"$6\\\"\" >> '$2'"
    , "\t@echo \"docdir=\\\"$7\\\"\" >> '$2'"
    , "\t@echo \"includedir=\\\"$8\\\"\" >> '$2'"
    , "\t@echo \"\" >> '$2'"
    , "\tcat wrappers/$1 >> '$2'"
    , "\t$(EXECUTABLE_FILE) '$2' ;"
    , "endef"
    , ""
    , "# Hacky function to patch up the 'haddock-interfaces' and 'haddock-html'"
    , "# fields in the package .conf files"
    , "define patchpackageconf"
    , "# $1 = package name (ex: 'bytestring')"
    , "# $2 = path to .conf file"
    , "# $3 = Docs Directory"
    , "\tcat '$2' | sed 's|haddock-interfaces.*|haddock-interfaces: $3/html/libraries/$1/$1.haddock|' \\"
    , "\t         | sed 's|haddock-html.*|haddock-html: $3/html/libraries/$1|' \\"
    , "\t       > '$2.copy'"
    , "\tmv '$2.copy' '$2'"
    , "endef"
    , ""
    , "# QUESTION : should we use shell commands?"
    , ""
    , ""
    , ".PHONY: install"
    , "install: install_lib install_bin install_includes"
    , "install: install_docs install_wrappers install_ghci"
    , "install: install_mingw update_package_db"
    , ""
    , "ActualBinsDir=${ghclibdir}/bin"
    , "WrapperBinsDir=${bindir}"
    , ""
    , "# We need to install binaries relative to libraries."
    , "BINARIES = $(wildcard ./bin/*)"
    , "install_bin:"
    , "\t@echo \"Copying binaries to $(ActualBinsDir)\""
    , "\t$(INSTALL_DIR) \"$(ActualBinsDir)\""
    , "\tfor i in $(BINARIES); do \\"
    , "\t\tcp -R $$i \"$(ActualBinsDir)\"; \\"
    , "\tdone"
    , ""
    , "install_ghci:"
    , "\t@echo \"Copying and installing ghci\""
    , "\t$(CREATE_SCRIPT) '$(WrapperBinsDir)/ghci'"
    , "\t@echo \"#!$(SHELL)\" >>  '$(WrapperBinsDir)/ghci'"
    , "\tcat wrappers/ghci-script >> '$(WrapperBinsDir)/ghci'"
    , "\t$(EXECUTABLE_FILE) '$(WrapperBinsDir)/ghci'"
    , ""
    , "LIBRARIES = $(wildcard ./lib/*)"
    , "install_lib:"
    , "\t@echo \"Copying libraries to $(libdir)\""
    , "\t$(INSTALL_DIR) \"$(libdir)\""
    , "\tfor i in $(LIBRARIES); do \\"
    , "\t\tcp -R $$i \"$(libdir)/\"; \\"
    , "\tdone"
    , ""
    , "INCLUDES = $(wildcard ./include/*)"
    , "install_includes:"
    , "\t@echo \"Copying libraries to $(includedir)\""
    , "\t$(INSTALL_DIR) \"$(includedir)\""
    , "\tfor i in $(INCLUDES); do \\"
    , "\t\tcp -R $$i \"$(includedir)/\"; \\"
    , "\tdone"
    , ""
    , "DOCS = $(wildcard ./docs/*)"
    , "install_docs:"
    , "\t@echo \"Copying libraries to $(docdir)\""
    , "\t$(INSTALL_DIR) \"$(docdir)\""
    , "\tfor i in $(DOCS); do \\"
    , "\t\tcp -R $$i \"$(docdir)/\"; \\"
    , "\tdone"
    , ""
    , "BINARY_NAMES=$(shell ls ./wrappers/)"
    , "install_wrappers:"
    , "\t@echo \"Installing Wrapper scripts\""
    , "\t$(INSTALL_DIR) \"$(WrapperBinsDir)\""
    , "\t$(foreach p, $(BINARY_NAMES),\\"
    , "\t\t$(call installscript,$p,$(WrapperBinsDir)/$p," ++
      "$(WrapperBinsDir),$(ActualBinsDir),$(ActualBinsDir)/$p," ++
      "$(libdir),$(docdir),$(includedir)))"
    , ""
    , "PKG_CONFS = $(wildcard $(libdir)/package.conf.d/*)"
    , "update_package_db:"
    , "\t@echo \"Updating the package DB\""
    , "\t$(foreach p, $(PKG_CONFS),\\"
    , "\t\t$(call patchpackageconf," ++
      "$(shell echo $(notdir $p) | sed 's/-\\([0-9]*[0-9]\\.\\)*conf//g')," ++
      "$p,$(docdir)))"
    , "\t'$(WrapperBinsDir)/ghc-pkg' recache"
    , ""
    , "# The 'foreach' that copies the mingw directory will only trigger a copy"
    , "# when the wildcard matches, therefore only on Windows."
    , "MINGW = $(wildcard ./mingw)"
    , "install_mingw:"
    , "\t@echo \"Installing MingGW\""
    , "\t$(INSTALL_DIR) \"$(prefix)/mingw\""
    , "\t$(foreach d, $(MINGW),\\"
    , "\t\tcp -R ./mingw \"$(prefix)\")"
    , "# END INSTALL"
    , "# ----------------------------------------------------------------------"
    ]

wrapper :: FilePath -> String
wrapper "ghc"         = ghcWrapper
wrapper "ghc-pkg"     = ghcPkgWrapper
wrapper "ghci"        = ghciWrapper
wrapper "ghci-script" = ghciScriptWrapper
wrapper "haddock"     = haddockWrapper
wrapper "hsc2hs"      = hsc2hsWrapper
wrapper "runghc"      = runGhcWrapper
wrapper _             = commonWrapper

-- | Wrapper scripts for different programs. Common is default wrapper.

ghcWrapper :: String
ghcWrapper = "exec \"$executablename\" -B\"$libdir\" ${1+\"$@\"}\n"

ghcPkgWrapper :: String
ghcPkgWrapper = unlines
    [ "PKGCONF=\"$libdir/package.conf.d\""
    , "exec \"$executablename\" --global-package-db \"$PKGCONF\" ${1+\"$@\"}" ]

ghciWrapper :: String
ghciWrapper = "exec \"$executablename\" --interactive \"$@\"\n"

haddockWrapper :: String
haddockWrapper = "exec \"$executablename\" -B\"$libdir\" -l\"$libdir\" ${1+\"$@\"}\n"

commonWrapper :: String
commonWrapper = "exec \"$executablename\" ${1+\"$@\"}\n"

hsc2hsWrapper :: String
hsc2hsWrapper = unlines
    [ "HSC2HS_EXTRA=\"--cflag=-fno-stack-protector --lflag=-fuse-ld=gold\""
    , "tflag=\"--template=$libdir/template-hsc.h\""
    , "Iflag=\"-I$includedir/\""
    , "for arg do"
    , "    case \"$arg\" in"
    , "# On OS X, we need to specify -m32 or -m64 in order to get gcc to"
    , "# build binaries for the right target. We do that by putting it in"
    , "# HSC2HS_EXTRA. When cabal runs hsc2hs, it passes a flag saying which"
    , "# gcc to use, so if we set HSC2HS_EXTRA= then we don't get binaries"
    , "# for the right platform. So for now we just don't set HSC2HS_EXTRA="
    , "# but we probably want to revisit how this works in the future."
    , "#        -c*)          HSC2HS_EXTRA=;;"
    , "#        --cc=*)       HSC2HS_EXTRA=;;"
    , "        -t*)          tflag=;;"
    , "        --template=*) tflag=;;"
    , "        --)           break;;"
    , "    esac"
    , "done"
    , "exec \"$executablename\" ${tflag:+\"$tflag\"} $HSC2HS_EXTRA ${1+\"$@\"} \"$Iflag\"" ]

runGhcWrapper :: String
runGhcWrapper = "exec \"$executablename\" -f \"$exedir/ghc\" ${1+\"$@\"}\n"

-- | We need to ship ghci executable, which basically just calls ghc with
-- | --interactive flag.
ghciScriptWrapper :: String
ghciScriptWrapper = unlines
    [ "DIR=`dirname \"$0\"`"
    , "executable=\"$DIR/ghc\""
    , "exec $executable --interactive \"$@\"" ]

-- | When not on Windows, we want to ship the 3 flavours of the iserv program
--   in binary distributions. This isn't easily achievable by just asking for
--   the package to be built, since here we're generating 3 different
--   executables out of just one package, so we need to specify all 3 contexts
--   explicitly and 'need' the result of building them.
needIservBins :: Action ()
needIservBins = do
    windows <- windowsHost
    when (not windows) $ do
        rtsways <- interpretInContext (vanillaContext Stage1 ghc) getRtsWays
        need =<< traverse programPath
                   [ Context Stage1 iserv w
                   | w <- [vanilla, profiling, dynamic]
                   , w `elem` rtsways
                   ]


module Rules.Clean (clean, cleanSourceTree, cleanRules) where

import qualified System.Directory as IO
import Base

clean :: Action ()
clean = do
    putBuild "| Removing Hadrian files..."
    cleanSourceTree
    path <- buildRoot
    putBuild $ "| Remove directory " ++ path ++ " (after build completes)"
    runAfter $ IO.removeDirectoryRecursive path -- since we can't delete the Shake database while Shake is running
    putSuccess "| Done. "

cleanSourceTree :: Action ()
cleanSourceTree = do
    path <- buildRoot
    forM_ [Stage0 ..] $ removeDirectory . (path -/-) . stageString
    removeDirectory "sdistprep"
    cleanFsUtils

-- Clean all temporary fs files copied by configure into the source folder
cleanFsUtils :: Action ()
cleanFsUtils = do
    let dirs = [ "utils/lndir/"
               , "utils/unlit/"
               , "rts/"
               , "libraries/base/include/"
               , "libraries/base/cbits/"
               ]
    liftIO $ forM_ dirs (flip removeFiles ["fs.*"])

cleanRules :: Rules ()
cleanRules = "clean" ~> clean


module Rules.Compile (compilePackage) where

import Hadrian.BuildPath
import Hadrian.Oracles.TextFile

import Base
import Context
import Expression
import Rules.Generate
import Settings
import Target
import Utilities

import qualified Text.Parsec as Parsec

-- * Rules for building objects and Haskell interface files

compilePackage :: [(Resource, Int)] -> Rules ()
compilePackage rs = do
    root <- buildRootRules
    -- We match all file paths that look like:
    --   <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
    --
    -- where:
    --   - the '...stuffs...' bits can be one or more path components,
    --   - the '<suffix>' part is a way prefix (e.g thr_p_, or nothing if
    --     vanilla) followed by an object file extension, without the dot
    --     (o, o-boot, hi, hi-boot),
    --
    -- and parse the information we need (stage, package path, ...) from
    -- the path and figure out the suitable way to produce that object file.
    objectFilesUnder root |%> \path -> do
        obj <- parsePath (parseBuildObject root) "<object file path parser>" path
        compileObject rs path obj
  where
    objectFilesUnder r = [ r -/- ("**/build/**/*" ++ pat)
                         | pat <- extensionPats ]

    exts = [ "o", "hi", "o-boot", "hi-boot" ]
    patternsFor e = [ "." ++ e, ".*_" ++ e ]
    extensionPats = concatMap patternsFor exts

-- * Object file paths types and parsers

{- We are using a non uniform representation that separates
   object files produced from Haskell code and from other
   languages, because the two "groups" have to be parsed
   differently enough that this would complicated the parser
   significantly.

   Indeed, non-Haskell files can only produce .o (or .thr_o, ...)
   files while Haskell modules can produce those as well as
   interface files, both in -boot or non-boot variants.

   Moreover, non-Haskell object files live under:
     <root>/stage<N>/<path/to/pkg>/build/{c,cmm,s}/

   while Haskell object/interface files live under:
     <root>/stage<N>/<path/to/pkg>/build/

   So the kind of object is partially determined by
   whether we're in c/, cmm/ or s/ but also by the
   object file's extension, in the case of a Haskell file.
   This could have been addressed with some knot-tying but
   Parsec's monad doesn't give us a MonadFix instance.

   We therefore stick to treating those two type of object
   files non uniformly.
-}

-- | Non Haskell source languages that we compile to get object files.
data SourceLang = Asm | C | Cmm deriving (Eq, Show)

parseSourceLang :: Parsec.Parsec String () SourceLang
parseSourceLang = Parsec.choice
  [ Parsec.char 'c' *> Parsec.choice
      [ Parsec.string "mm" *> pure Cmm
      , pure C
      ]
  , Parsec.char 's' *> pure Asm
  ]

type Basename = String

parseBasename :: Parsec.Parsec String () Basename
parseBasename = Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.char '.')

-- | > <c|cmm|s>/<file>.<way prefix>_o
data NonHsObject = NonHsObject SourceLang Basename Way
  deriving (Eq, Show)

parseNonHsObject :: Parsec.Parsec String () NonHsObject
parseNonHsObject = do
    lang <- parseSourceLang
    _ <- Parsec.char '/'
    file <- parseBasename
    way <- parseWayPrefix vanilla
    _ <- Parsec.char 'o'
    return (NonHsObject lang file way)

-- | > <o|hi|o-boot|hi-boot>
data SuffixType = O | Hi | OBoot | HiBoot deriving (Eq, Show)

parseSuffixType :: Parsec.Parsec String () SuffixType
parseSuffixType = Parsec.choice
  [ Parsec.char 'o' *> Parsec.choice
      [ Parsec.string "-boot" *> pure OBoot
      , pure O
      ]
  , Parsec.string "hi" *> Parsec.choice
      [ Parsec.string "-boot" *> pure HiBoot
      , pure Hi
      ]
  ]

-- | > <way prefix>_<o|hi|o-boot|hi-boot>
data Extension = Extension Way SuffixType deriving (Eq, Show)

parseExtension :: Parsec.Parsec String () Extension
parseExtension = Extension <$> parseWayPrefix vanilla <*> parseSuffixType

-- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
data HsObject = HsObject Basename Extension deriving (Eq, Show)

parseHsObject :: Parsec.Parsec String () HsObject
parseHsObject = do
    file <- parseBasename
    ext <- parseExtension
    return (HsObject file ext)

data Object = Hs HsObject | NonHs NonHsObject deriving (Eq, Show)

parseObject :: Parsec.Parsec String () Object
parseObject = Parsec.choice
    [ NonHs <$> parseNonHsObject
    , Hs    <$> parseHsObject ]

-- * Toplevel parsers

parseBuildObject :: FilePath -> Parsec.Parsec String () (BuildPath Object)
parseBuildObject root = parseBuildPath root parseObject

-- * Getting contexts from objects

objectContext :: BuildPath Object -> Context
objectContext (BuildPath _ stage pkgPath obj) =
    Context stage (unsafeFindPackageByPath pkgPath) way
  where
    way = case obj of
        NonHs (NonHsObject _lang _file w)         -> w
        Hs    (HsObject _file (Extension w _suf)) -> w

-- * Building an object

compileHsObject
    :: [(Resource, Int)] -> FilePath -> BuildPath Object -> HsObject -> Action ()
compileHsObject rs objpath b@(BuildPath _root stage _path _o) hsobj =
  case hsobj of
    HsObject _basename (Extension way Hi    ) -> need [objpath -<.> osuf     way]
    HsObject _basename (Extension way HiBoot) -> need [objpath -<.> obootsuf way]
    HsObject _basename (Extension way suf) -> do
        let ctx = objectContext b
        ctxPath <- contextPath ctx
        (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
        need (src:deps)
        needLibrary =<< contextDependencies ctx
        buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
        -- Andrey: It appears that the previous refactoring has broken
        -- multiple-output build rules. Ideally, we should bring multiple-output
        -- rules back, see: https://github.com/snowleopard/hadrian/issues/216.
        -- As a temporary solution, I'm using Shake's new 'produces' feature to
        -- record that this rule also produces a corresponding interface file.
        let hi | suf == O     = objpath -<.> hisuf     way
               | suf == OBoot = objpath -<.> hibootsuf way
               | otherwise    = error "Internal error: unknown Haskell object extension"
        produces [hi]

compileNonHsObject
  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> NonHsObject
  -> Action ()
compileNonHsObject rs objpath b@(BuildPath _root stage _path _o) nonhsobj =
  case nonhsobj of
    NonHsObject lang _basename _way ->
      go (builderFor lang) (toSrcFor lang)

  where builderFor C = Ghc CompileCWithGhc
        builderFor _ = Ghc CompileHs

        toSrcFor Asm = obj2src "S"   (const False)
        toSrcFor C   = obj2src "c"   (const False)
        toSrcFor Cmm = obj2src "cmm" isGeneratedCmmFile

        go builder tosrc = do
            let ctx = objectContext b
            src <- tosrc ctx objpath
            need [src]
            needDependencies ctx src (objpath <.> "d")
            buildWithResources rs $ target ctx (builder stage) [src] [objpath]

compileObject
  :: [(Resource, Int)] -> FilePath -> BuildPath Object -> Action ()
compileObject rs objpath b@(BuildPath _root _stage _path (Hs o)) =
  compileHsObject rs objpath b o
compileObject rs objpath b@(BuildPath _root _stage _path (NonHs o)) =
  compileNonHsObject rs objpath b o

-- * Helpers

-- | Discover dependencies of a given source file by iteratively calling @gcc@
-- in the @-MM -MG@ mode and building generated dependencies if they are missing
-- until reaching a fixed point.
needDependencies :: Context -> FilePath -> FilePath -> Action ()
needDependencies context@Context {..} src depFile = discover
  where
    discover = do
        build $ target context (Cc FindCDependencies stage) [src] [depFile]
        deps <- parseFile depFile
        -- Generated dependencies, if not yet built, will not be found and hence
        -- will be referred to simply by their file names.
        let notFound = filter (\file -> file == takeFileName file) deps
        -- We find the full paths to generated dependencies, so we can request
        -- to build them by calling 'need'.
        todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound

        if null todo
        then need deps -- The list of dependencies is final, need all
        else do
            need todo  -- Build newly discovered generated dependencies
            discover   -- Continue the discovery process

    parseFile :: FilePath -> Action [String]
    parseFile file = do
        input <- liftIO $ readFile file
        case parseMakefile input of
            [(_file, deps)] -> return deps
            _               -> return []

-- | Find a given 'FilePath' in the list of generated files in the given
-- 'Context' and return its full path.
fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
fullPathIfGenerated context file = interpretInContext context $ do
    generated <- generatedDependencies
    return $ find ((== file) . takeFileName) generated

obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath
obj2src extension isGenerated context@Context {..} obj
    | isGenerated src = return src
    | otherwise       = (pkgPath package ++) <$> suffix
  where
    src    = obj -<.> extension
    suffix = do
        path <- buildPath context
        return $ fromMaybe ("Cannot determine source for " ++ obj)
               $ stripPrefix (path -/- extension) src


module Rules.Configure (configureRules) where

import Base
import Builder
import CommandLine
import Context
import Packages
import Target
import Utilities

import qualified System.Info.Extra as System

-- TODO: Make this list complete.
-- | Files generated by running the @configure@ script.
configureResults :: [FilePath]
configureResults =
    [ configFile, "settings", configH, "compiler/ghc.cabal", "rts/rts.cabal"]

configureRules :: Rules ()
configureRules = do
    configureResults &%> \outs -> do
        skip <- not <$> cmdConfigure
        if skip
        then unlessM (doesFileExist configFile) $
            error $ "Configuration file " ++ configFile ++ " is missing.\n"
                ++ "Run the configure script manually or let Hadrian run it "
                ++ "automatically by passing the flag --configure."
        else do
            -- We cannot use windowsHost here due to a cyclic dependency.
            when System.isWindows $ do
                putBuild "| Checking for Windows tarballs..."
                quietly $ cmd ["bash", "mk/get-win32-tarballs.sh", "download", System.arch]
            let srcs    = map (<.> "in") outs
                context = vanillaContext Stage0 compiler
            need srcs
            build $ target context (Configure ".") srcs outs
            -- TODO: This is fragile: we should remove this from behind the
            -- @--configure@ flag and add a proper dependency tracking.
            -- We need to copy the directory with unpacked Windows tarball to
            -- the build directory, so that the built GHC has access to it.
            -- See https://github.com/snowleopard/hadrian/issues/564.
            when System.isWindows $ do
                root <- buildRoot
                copyDirectory "inplace/mingw" (root -/- "mingw")
                mingwFiles <- liftIO $ getDirectoryFilesIO "." [root -/- "mingw/**"]
                produces mingwFiles

    ["configure", configH <.> "in"] &%> \_ -> do
        skip <- not <$> cmdConfigure
        if skip
        then unlessM (doesFileExist "configure") $
            error $ "The configure script is missing.\nRun the boot script "
                ++ "manually let Hadrian run it automatically by passing the "
                ++ "flag --configure."
        else do
            need ["configure.ac"]
            putBuild "| Running boot..."
            verbosity <- getVerbosity
            quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot --hadrian"


module Rules.Dependencies (buildPackageDependencies) where

import Data.Bifunctor
import Data.Function

import Base
import Context
import Expression
import Hadrian.BuildPath
import Oracles.ModuleFiles
import Rules.Generate
import Settings
import Target
import Utilities

import qualified Text.Parsec as Parsec

buildPackageDependencies :: [(Resource, Int)] -> Rules ()
buildPackageDependencies rs = do
    root <- buildRootRules
    root -/- "**/.dependencies.mk" %> \mk -> do
        DepMkFile stage pkgpath <- getDepMkFile root mk
        let context = Context stage (unsafeFindPackageByPath pkgpath) vanilla
        srcs <- hsSources context
        gens <- interpretInContext context generatedDependencies
        need (srcs ++ gens)
        if null srcs
        then writeFileChanged mk ""
        else buildWithResources rs $ target context
            (Ghc FindHsDependencies $ Context.stage context) srcs [mk]
        removeFile $ mk <.> "bak"

    root -/- "**/.dependencies" %> \deps -> do
        mkDeps <- readFile' (deps <.> "mk")
        writeFileChanged deps . unlines
                              . map (\(src, deps) -> unwords $ src : deps)
                              . map (bimap unifyPath (map unifyPath))
                              . map (bimap head concat . unzip)
                              . groupBy ((==) `on` fst)
                              . sortBy (compare `on` fst)
                              $ parseMakefile mkDeps

data DepMkFile = DepMkFile Stage FilePath deriving (Eq, Show)

parseDepMkFile :: FilePath -> Parsec.Parsec String () DepMkFile
parseDepMkFile root = do
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgPath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/.dependencies.mk")
    return (DepMkFile stage pkgPath)

getDepMkFile :: FilePath -> FilePath -> Action DepMkFile
getDepMkFile root = parsePath (parseDepMkFile root) "<dependencies file>"


module Rules.Documentation (
    -- * Rules
    buildPackageDocumentation, documentationRules,

    -- * Utilities
    haddockDependencies
    ) where

import Hadrian.BuildPath
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type

import Rules.Generate (ghcPrimDependencies)
import Base
import Context
import Expression (getContextData, interpretInContext, (?), package)
import Flavour
import Oracles.ModuleFiles
import Packages
import Settings
import Target
import Utilities

import Data.List (union)
import qualified Data.Set    as Set
import qualified Text.Parsec as Parsec

docRoot :: FilePath
docRoot = "docs"

htmlRoot :: FilePath
htmlRoot = docRoot -/- "html"

pdfRoot :: FilePath
pdfRoot = docRoot -/- "pdfs"

archiveRoot :: FilePath
archiveRoot = docRoot -/- "archives"

manPageBuildPath :: FilePath
manPageBuildPath = "docs/users_guide/build-man/ghc.1"

-- TODO: Get rid of this hack.
docContext :: Context
docContext = vanillaContext Stage2 (library "Documentation" "docs")

docPaths :: [FilePath]
docPaths = ["libraries", "users_guide", "Haddock"]

pathPdf :: FilePath -> FilePath
pathPdf path = pdfRoot -/- path <.> ".pdf"

pathIndex :: FilePath -> FilePath
pathIndex path = htmlRoot -/- path -/- "index.html"

pathArchive :: FilePath -> FilePath
pathArchive path = archiveRoot -/- path <.> "html.tar.xz"

-- TODO: Get rid of this hack.
pathPath :: FilePath -> FilePath
pathPath "users_guide" = "docs/users_guide"
pathPath "Haddock" = "utils/haddock/doc"
pathPath _ = ""

-- | Build all documentation
documentationRules :: Rules ()
documentationRules = do
    buildDocumentationArchives
    buildHtmlDocumentation
    buildManPage
    buildPdfDocumentation

    -- a phony rule that runs Haddock for "Haskell Hierarchical Libraries" and
    -- the "GHC-API"
    "docs-haddock" ~> do
        root <- buildRoot
        need [ root -/- pathIndex "libraries" ]

    -- a phony rule that runs Haddock, builds the User's guide, builds
    -- Haddock's manual, and builds man pages
    "docs" ~> do
        root <- buildRoot
        doctargets <- ghcDocs =<< flavour
        let html     = htmlRoot -/- "index.html" -- also implies "docs-haddock"
            archives = map pathArchive docPaths
            pdfs     = map pathPdf $ docPaths \\ ["libraries"]

            targets = -- include PDFs unless --docs=no-sphinx[-pdf] is
                      -- passed.
                      concat [ pdfs | SphinxPDFs `Set.member` doctargets ]

                      -- include manpage unless --docs=no-sphinx[-man] is given.
                   ++ [ manPageBuildPath | SphinxMan `Set.member` doctargets ]

                      -- include toplevel html target uness we neither want
                      -- haddocks nor html pages produced by sphinx.
                   ++ [ html | Set.size (doctargets `Set.intersection`
                                         Set.fromList [Haddocks, SphinxHTML]
                                        ) > 0 ]

                      -- include archives for whatever targets remain from
                      -- the --docs arguments we got.
                   ++ [ ar
                      | (ar, doc) <- zip archives docPaths
                      , archiveTarget doc `Set.member` doctargets ]

        need $ map (root -/-) targets

    where archiveTarget "libraries"   = Haddocks
          archiveTarget _             = SphinxHTML

------------------------------------- HTML -------------------------------------

-- | Build rules for HTML documentation.
buildHtmlDocumentation :: Rules ()
buildHtmlDocumentation = do
    mapM_ buildSphinxHtml $ docPaths \\ ["libraries"]
    buildLibraryDocumentation
    root <- buildRootRules

    root -/- htmlRoot -/- "index.html" %> \file -> do
        doctargets <- ghcDocs =<< flavour

        -- We include the HTML output of haddock for libraries unless
        -- told not to (e.g with --docs=no-haddocks). Likewise for
        -- the HTML version of the users guide or the Haddock manual.
        let targets = [ "libraries" | Haddocks `Set.member` doctargets ]
                   ++ concat [ ["users_guide", "Haddock"]
                             | SphinxHTML `Set.member` doctargets ]
        need $ map ((root -/-) . pathIndex) targets

        copyFileUntracked "docs/index.html" file

-- | Compile a Sphinx ReStructured Text package to HTML.
buildSphinxHtml :: FilePath -> Rules ()
buildSphinxHtml path = do
    root <- buildRootRules
    root -/- htmlRoot -/- path -/- "index.html" %> \file -> do
        let dest = takeDirectory file
        build $ target docContext (Sphinx Html) [pathPath path] [dest]

------------------------------------ Haddock -----------------------------------

-- | Build the haddocks for GHC's libraries.
buildLibraryDocumentation :: Rules ()
buildLibraryDocumentation = do
    root <- buildRootRules

    -- Building the "Haskell Hierarchical Libraries" index
    root -/- htmlRoot -/- "libraries/index.html" %> \file -> do
        need [ "libraries/prologue.txt" ]

        -- We want Haddocks for everything except `rts` to be built, but we
        -- don't want the index to be polluted by stuff from `ghc`-the-library
        -- (there will be a separate top-level link to those Haddocks).
        haddocks <- allHaddocks
        let neededDocs = filter (\x -> takeFileName x /= "rts.haddock") haddocks
            libDocs = filter (\x -> takeFileName x /= "ghc.haddock") neededDocs

        need neededDocs
        build $ target docContext (Haddock BuildIndex) libDocs [file]

allHaddocks :: Action [FilePath]
allHaddocks = do
    pkgs <- stagePackages Stage1
    sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg
             | pkg <- pkgs, isLibrary pkg, pkgName pkg /= "rts" ]

-- Note: this build rule creates plenty of files, not just the .haddock one.
-- All of them go into the 'docRoot' subdirectory. Pedantically tracking all
-- built files in the Shake database seems fragile and unnecessary.
buildPackageDocumentation :: Rules ()
buildPackageDocumentation = do
    root <- buildRootRules

    -- Per-package haddocks
    root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do
        ctx <- pkgDocContext <$> getPkgDocTarget root file
        -- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files.
        syn  <- pkgSynopsis    (Context.package ctx)
        desc <- pkgDescription (Context.package ctx)
        let prologue = if null desc then syn else desc
        liftIO $ writeFile file prologue

    root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do
        context <- pkgDocContext <$> getPkgDocTarget root file
        need [ takeDirectory file  -/- "haddock-prologue.txt"]
        haddocks <- haddockDependencies context

        -- `ghc-prim` has a source file for 'GHC.Prim' which is generated just
        -- for Haddock. We need to 'union' (instead of '++') to avoid passing
        -- 'GHC.PrimopWrappers' (which unfortunately shows up in both
        -- `generatedSrcs` and `vanillaSrcs`) to Haddock twice.
        generatedSrcs <- interpretInContext context (Expression.package ghcPrim ? ghcPrimDependencies)
        vanillaSrcs <- hsSources context
        let srcs = vanillaSrcs `union` generatedSrcs

        need $ srcs ++ haddocks

        -- Build Haddock documentation
        -- TODO: Pass the correct way from Rules via Context.
        dynamicPrograms <- dynamicGhcPrograms =<< flavour
        let haddockWay = if dynamicPrograms then dynamic else vanilla
        build $ target (context {way = haddockWay}) (Haddock BuildPackage) srcs [file]

data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName
  deriving (Eq, Show)

pkgDocContext :: PkgDocTarget -> Context
pkgDocContext target = Context Stage1 (unsafeFindPackageByName name) vanilla
  where
    name = case target of DotHaddock n      -> n
                          HaddockPrologue n -> n

parsePkgDocTarget :: FilePath -> Parsec.Parsec String () PkgDocTarget
parsePkgDocTarget root = do
  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
  _ <- Parsec.string (htmlRoot ++ "/")
  _ <- Parsec.string "libraries/"
  pkgname <- Parsec.manyTill Parsec.anyChar (Parsec.char '/')
  Parsec.choice
    [ Parsec.try (Parsec.string "haddock-prologue.txt")
        *> pure (HaddockPrologue pkgname)
    , Parsec.string (pkgname <.> "haddock")
        *> pure (DotHaddock pkgname)
    ]

getPkgDocTarget :: FilePath -> FilePath -> Action PkgDocTarget
getPkgDocTarget root path =
  parsePath (parsePkgDocTarget root) "<doc target>" path

-------------------------------------- PDF -------------------------------------

-- | Build all PDF documentation
buildPdfDocumentation :: Rules ()
buildPdfDocumentation = mapM_ buildSphinxPdf docPaths

-- | Compile a Sphinx ReStructured Text package to LaTeX
buildSphinxPdf :: FilePath -> Rules ()
buildSphinxPdf path = do
    root <- buildRootRules
    root -/- pdfRoot -/- path <.> "pdf" %> \file -> do
        withTempDir $ \dir -> do
            build $ target docContext (Sphinx Latex) [pathPath path] [dir]
            build $ target docContext Xelatex [path <.> "tex"] [dir]
            copyFileUntracked (dir -/- path <.> "pdf") file

------------------------------------ Archive -----------------------------------

-- | Build documentation archives.
buildDocumentationArchives :: Rules ()
buildDocumentationArchives = mapM_ buildArchive docPaths

buildArchive :: FilePath -> Rules ()
buildArchive path = do
    root <- buildRootRules
    root -/- pathArchive path %> \file -> do
        root <- buildRoot
        let src = root -/- pathIndex path
        need [src]
        build $ target docContext (Tar Create) [takeDirectory src] [file]

-- | Build the man page.
buildManPage :: Rules ()
buildManPage = do
    root <- buildRootRules
    root -/- manPageBuildPath %> \file -> do
        need ["docs/users_guide/ghc.rst"]
        withTempDir $ \dir -> do
            build $ target docContext (Sphinx Man) ["docs/users_guide"] [dir]
            copyFileUntracked (dir -/- "ghc.1") file

-- | Find the Haddock files for the dependencies of the current library.
haddockDependencies :: Context -> Action [FilePath]
haddockDependencies context = do
    depNames <- interpretInContext context (getContextData depNames)
    sequence [ pkgHaddockFile $ vanillaContext Stage1 depPkg
             | Just depPkg <- map findPackageByName depNames, depPkg /= rts ]


module Rules.Generate (
    isGeneratedCmmFile, compilerDependencies, generatePackageCode,
    generateRules, copyRules, generatedDependencies, generatedGhcDependencies,
    ghcPrimDependencies
    ) where

import Base
import Expression
import Flavour
import Oracles.Flag
import Oracles.ModuleFiles
import Oracles.Setting
import Packages
import Rules.Gmp
import Rules.Libffi
import Settings
import Target
import Utilities

-- | Track this file to rebuild generated files whenever it changes.
trackGenerateHs :: Expr ()
trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"]

primopsSource :: FilePath
primopsSource = "compiler/prelude/primops.txt.pp"

primopsTxt :: Stage -> FilePath
primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"

isGeneratedCmmFile :: FilePath -> Bool
isGeneratedCmmFile file = takeBaseName file == "AutoApply"

ghcPrimDependencies :: Expr [FilePath]
ghcPrimDependencies = do
    stage <- getStage
    path  <- expr $ buildPath (vanillaContext stage ghcPrim)
    return [path -/- "GHC/Prim.hs", path -/- "GHC/PrimopWrappers.hs"]

derivedConstantsDependencies :: [FilePath]
derivedConstantsDependencies = fmap (generatedDir -/-)
    [ "DerivedConstants.h"
    , "GHCConstantsHaskellExports.hs"
    , "GHCConstantsHaskellType.hs"
    , "GHCConstantsHaskellWrappers.hs" ]

compilerDependencies :: Expr [FilePath]
compilerDependencies = do
    root    <- getBuildRoot
    stage   <- getStage
    isGmp   <- (== integerGmp) <$> getIntegerPackage
    ghcPath <- expr $ buildPath (vanillaContext stage compiler)
    gmpPath <- expr gmpBuildPath
    rtsPath <- expr (rtsBuildPath stage)
    mconcat [ return ((root -/-) <$> derivedConstantsDependencies)
            , notStage0 ? isGmp ? return [gmpPath -/- gmpLibraryH]
            , notStage0 ? return ((rtsPath -/-) <$> libffiDependencies)
            , return $ fmap (ghcPath -/-)
                  [ "primop-can-fail.hs-incl"
                  , "primop-code-size.hs-incl"
                  , "primop-commutable.hs-incl"
                  , "primop-data-decl.hs-incl"
                  , "primop-fixity.hs-incl"
                  , "primop-has-side-effects.hs-incl"
                  , "primop-list.hs-incl"
                  , "primop-out-of-line.hs-incl"
                  , "primop-primop-info.hs-incl"
                  , "primop-strictness.hs-incl"
                  , "primop-tag.hs-incl"
                  , "primop-vector-tycons.hs-incl"
                  , "primop-vector-tys-exports.hs-incl"
                  , "primop-vector-tys.hs-incl"
                  , "primop-vector-uniques.hs-incl" ] ]

generatedDependencies :: Expr [FilePath]
generatedDependencies = do
    root     <- getBuildRoot
    stage    <- getStage
    rtsPath  <- expr (rtsBuildPath stage)
    includes <- expr includesDependencies
    mconcat [ package compiler ? compilerDependencies
            , package ghcPrim  ? ghcPrimDependencies
            , package rts      ? return (fmap (rtsPath -/-) libffiDependencies
                ++ includes
                ++ fmap (root -/-) derivedConstantsDependencies)
            , stage0 ? return includes ]

generate :: FilePath -> Context -> Expr String -> Action ()
generate file context expr = do
    contents <- interpretInContext context expr
    writeFileChanged file contents
    putSuccess $ "| Successfully generated " ++ file ++ "."

generatePackageCode :: Context -> Rules ()
generatePackageCode context@(Context stage pkg _) = do
    root <- buildRootRules
    let dir         = buildDir context
        generated f = (root -/- dir ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
        go gen file = generate file context gen
    generated ?> \file -> do
        let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
        (src, builder) <- unpack <$> findGenerator context file
        need [src]
        build $ target context builder [src] [file]
        let boot = src -<.> "hs-boot"
        whenM (doesFileExist boot) $ do
            let target = file -<.> "hs-boot"
            copyFile boot target
            produces [target]

    priority 2.0 $ do
        when (pkg == compiler) $ do
            root <//> dir -/- "Config.hs" %> go generateConfigHs
            root <//> dir -/- "*.hs-incl" %> genPrimopCode context
        when (pkg == ghcPrim) $ do
            root <//> dir -/- "GHC/Prim.hs" %> genPrimopCode context
            root <//> dir -/- "GHC/PrimopWrappers.hs" %> genPrimopCode context
        when (pkg == ghcPkg) $
            root <//> dir -/- "Version.hs" %> go generateVersionHs

    when (pkg == compiler) $ do
        root -/- primopsTxt stage %> \file -> do
            includes <- includesDependencies
            need $ [primopsSource] ++ includes
            build $ target context HsCpp [primopsSource] [file]

        root -/- stageString stage <//> "ghc_boot_platform.h" %>
            go generateGhcBootPlatformH

    when (pkg == rts) $ do
        root <//> dir -/- "cmm/AutoApply.cmm" %> \file ->
            build $ target context GenApply [] [file]
        -- TODO: This should be fixed properly, e.g. generated here on demand.
        (root <//> dir -/- "DerivedConstants.h") <~ (buildRoot <&> (-/- generatedDir))
        (root <//> dir -/- "ghcautoconf.h") <~ (buildRoot <&> (-/- generatedDir))
        (root <//> dir -/- "ghcplatform.h") <~ (buildRoot <&> (-/- generatedDir))
        (root <//> dir -/- "ghcversion.h") <~ (buildRoot <&> (-/- generatedDir))
 where
    pattern <~ mdir = pattern %> \file -> do
        dir <- mdir
        copyFile (dir -/- takeFileName file) file

genPrimopCode :: Context -> FilePath -> Action ()
genPrimopCode context@(Context stage _pkg _) file = do
    root <- buildRoot
    need [root -/- primopsTxt stage]
    build $ target context GenPrimopCode [root -/- primopsTxt stage] [file]

copyRules :: Rules ()
copyRules = do
    root <- buildRootRules
    forM_ [Stage0 ..] $ \stage -> do
        let prefix = root -/- stageString stage -/- "lib"

            infixl 1 <~
            pattern <~ mdir = pattern %> \file -> do
                dir <- mdir
                copyFile (dir -/- makeRelative prefix file) file

        prefix -/- "ghc-usage.txt"     <~ return "driver"
        prefix -/- "ghci-usage.txt"    <~ return "driver"
        prefix -/- "llvm-targets"      <~ return "."
        prefix -/- "llvm-passes"       <~ return "."
        prefix -/- "platformConstants" <~ (buildRoot <&> (-/- generatedDir))
        prefix -/- "settings"          <~ return "."
        prefix -/- "template-hsc.h"    <~ return (pkgPath hsc2hs)

        prefix -/- "html//*"           <~ return "utils/haddock/haddock-api/resources"
        prefix -/- "latex//*"          <~ return "utils/haddock/haddock-api/resources"

generateRules :: Rules ()
generateRules = do
    root <- buildRootRules
    priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
    priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
    priority 2.0 $ (root -/- generatedDir -/-  "ghcversion.h") <~ generateGhcVersionH

    -- TODO: simplify, get rid of fake rts context
    root -/- generatedDir ++ "//*" %> \file -> do
        withTempDir $ \dir -> build $
            target (rtsContext Stage1) DeriveConstants [] [file, dir]
  where
    file <~ gen = file %> \out -> generate out emptyTarget gen

-- TODO: Use the Types, Luke! (drop partial function)
-- We sometimes need to evaluate expressions that do not require knowing all
-- information about the context. In this case, we don't want to know anything.
emptyTarget :: Context
emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
                             (error "Rules.Generate.emptyTarget: unknown package")

-- Generators

-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' is a valid C preprocessor identifier.
cppify :: String -> String
cppify = replaceEq '-' '_' . replaceEq '.' '_'

-- | Generate @ghcplatform.h@ header.
generateGhcPlatformH :: Expr String
generateGhcPlatformH = do
    trackGenerateHs
    hostPlatform   <- getSetting HostPlatform
    hostArch       <- getSetting HostArch
    hostOs         <- getSetting HostOs
    hostVendor     <- getSetting HostVendor
    targetPlatform <- getSetting TargetPlatform
    targetArch     <- getSetting TargetArch
    targetOs       <- getSetting TargetOs
    targetVendor   <- getSetting TargetVendor
    ghcUnreg       <- getFlag    GhcUnregisterised
    return . unlines $
        [ "#ifndef __GHCPLATFORM_H__"
        , "#define __GHCPLATFORM_H__"
        , ""
        , "#define BuildPlatform_TYPE  " ++ cppify hostPlatform
        , "#define HostPlatform_TYPE   " ++ cppify targetPlatform
        , ""
        , "#define " ++ cppify hostPlatform   ++ "_BUILD 1"
        , "#define " ++ cppify targetPlatform ++ "_HOST 1"
        , ""
        , "#define " ++ hostArch   ++ "_BUILD_ARCH 1"
        , "#define " ++ targetArch ++ "_HOST_ARCH 1"
        , "#define BUILD_ARCH " ++ show hostArch
        , "#define HOST_ARCH "  ++ show targetArch
        , ""
        , "#define " ++ hostOs   ++ "_BUILD_OS 1"
        , "#define " ++ targetOs ++ "_HOST_OS 1"
        , "#define BUILD_OS " ++ show hostOs
        , "#define HOST_OS "  ++ show targetOs
        , ""
        , "#define " ++ hostVendor   ++ "_BUILD_VENDOR 1"
        , "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
        , "#define BUILD_VENDOR " ++ show hostVendor
        , "#define HOST_VENDOR "  ++ show targetVendor
        , ""
        , "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
        , "#define TargetPlatform_TYPE " ++ cppify targetPlatform
        , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
        , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
        , "#define TARGET_ARCH " ++ show targetArch
        , "#define " ++ targetOs ++ "_TARGET_OS 1"
        , "#define TARGET_OS " ++ show targetOs
        , "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
        ++
        [ "#define UnregisterisedCompiler 1" | ghcUnreg ]
        ++
        [ "\n#endif /* __GHCPLATFORM_H__ */" ]

-- | Generate @Config.hs@ files.
generateConfigHs :: Expr String
generateConfigHs = do
    trackGenerateHs
    cProjectName        <- getSetting ProjectName
    cProjectGitCommitId <- getSetting ProjectGitCommitId
    cProjectVersion     <- getSetting ProjectVersion
    cProjectVersionInt  <- getSetting ProjectVersionInt
    cProjectPatchLevel  <- getSetting ProjectPatchLevel
    cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
    cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
    cBooterVersion      <- getSetting GhcVersion
    intLib              <- getIntegerPackage
    debugged            <- ghcDebugged    <$> expr flavour
    let cIntegerLibraryType
            | intLib == integerGmp    = "IntegerGMP"
            | intLib == integerSimple = "IntegerSimple"
            | otherwise = error $ "Unknown integer library: " ++ pkgName intLib
    cGhcWithInterpreter        <- expr $ yesNo <$> ghcWithInterpreter
    cGhcWithNativeCodeGen      <- expr $ yesNo <$> ghcWithNativeCodeGen
    cGhcWithSMP                <- expr $ yesNo <$> ghcWithSMP
    cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
    cLeadingUnderscore         <- expr $ yesNo <$> flag LeadingUnderscore
    cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
    cLibFFI                    <- expr useLibFFIForAdjustors
    rtsWays                    <- getRtsWays
    cGhcRtsWithLibdw           <- getFlag WithLibdw
    let cGhcRTSWays = unwords $ map show rtsWays
    return $ unlines
        [ "{-# LANGUAGE CPP #-}"
        , "module Config where"
        , ""
        , "import GhcPrelude"
        , ""
        , "#include \"ghc_boot_platform.h\""
        , ""
        , "data IntegerLibrary = IntegerGMP"
        , "                    | IntegerSimple"
        , "                    deriving Eq"
        , ""
        , "cBuildPlatformString :: String"
        , "cBuildPlatformString = BuildPlatform_NAME"
        , "cHostPlatformString :: String"
        , "cHostPlatformString = HostPlatform_NAME"
        , "cTargetPlatformString :: String"
        , "cTargetPlatformString = TargetPlatform_NAME"
        , ""
        , "cProjectName          :: String"
        , "cProjectName          = " ++ show cProjectName
        , "cProjectGitCommitId   :: String"
        , "cProjectGitCommitId   = " ++ show cProjectGitCommitId
        , "cProjectVersion       :: String"
        , "cProjectVersion       = " ++ show cProjectVersion
        , "cProjectVersionInt    :: String"
        , "cProjectVersionInt    = " ++ show cProjectVersionInt
        , "cProjectPatchLevel    :: String"
        , "cProjectPatchLevel    = " ++ show cProjectPatchLevel
        , "cProjectPatchLevel1   :: String"
        , "cProjectPatchLevel1   = " ++ show cProjectPatchLevel1
        , "cProjectPatchLevel2   :: String"
        , "cProjectPatchLevel2   = " ++ show cProjectPatchLevel2
        , "cBooterVersion        :: String"
        , "cBooterVersion        = " ++ show cBooterVersion
        , "cStage                :: String"
        , "cStage                = show (STAGE :: Int)"
        , "cIntegerLibrary       :: String"
        , "cIntegerLibrary       = " ++ show (pkgName intLib)
        , "cIntegerLibraryType   :: IntegerLibrary"
        , "cIntegerLibraryType   = " ++ cIntegerLibraryType
        , "cGhcWithInterpreter   :: String"
        , "cGhcWithInterpreter   = " ++ show cGhcWithInterpreter
        , "cGhcWithNativeCodeGen :: String"
        , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
        , "cGhcWithSMP           :: String"
        , "cGhcWithSMP           = " ++ show cGhcWithSMP
        , "cGhcRTSWays           :: String"
        , "cGhcRTSWays           = " ++ show cGhcRTSWays
        , "cGhcEnableTablesNextToCode :: String"
        , "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
        , "cLeadingUnderscore    :: String"
        , "cLeadingUnderscore    = " ++ show cLeadingUnderscore
        , "cGHC_UNLIT_PGM        :: String"
        , "cGHC_UNLIT_PGM        = " ++ show cGHC_UNLIT_PGM
        , "cLibFFI               :: Bool"
        , "cLibFFI               = " ++ show cLibFFI
        , "cGhcThreaded :: Bool"
        , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays)
        , "cGhcDebugged :: Bool"
        , "cGhcDebugged = " ++ show debugged
        , "cGhcRtsWithLibdw :: Bool"
        , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]

-- | Generate @ghcautoconf.h@ header.
generateGhcAutoconfH :: Expr String
generateGhcAutoconfH = do
    trackGenerateHs
    configHContents  <- expr $ map undefinePackage <$> readFileLines configH
    tablesNextToCode <- expr ghcEnableTablesNextToCode
    ghcUnreg         <- getFlag    GhcUnregisterised
    ccLlvmBackend    <- getSetting CcLlvmBackend
    ccClangBackend   <- getSetting CcClangBackend
    return . unlines $
        [ "#ifndef __GHCAUTOCONF_H__"
        , "#define __GHCAUTOCONF_H__" ]
        ++ configHContents ++
        [ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
        ++
        [ "\n#define llvm_CC_FLAVOR 1"      | ccLlvmBackend == "1" ]
        ++
        [ "\n#define clang_CC_FLAVOR 1"     | ccClangBackend == "1" ]
        ++
        [ "#endif /* __GHCAUTOCONF_H__ */" ]
  where
    undefinePackage s
        | "#define PACKAGE_" `isPrefixOf` s
            = "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
        | otherwise = s

-- | Generate @ghc_boot_platform.h@ headers.
generateGhcBootPlatformH :: Expr String
generateGhcBootPlatformH = do
    trackGenerateHs
    stage <- getStage
    let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
    buildPlatform  <- chooseSetting BuildPlatform HostPlatform
    buildArch      <- chooseSetting BuildArch     HostArch
    buildOs        <- chooseSetting BuildOs       HostOs
    buildVendor    <- chooseSetting BuildVendor   HostVendor
    hostPlatform   <- chooseSetting HostPlatform  TargetPlatform
    hostArch       <- chooseSetting HostArch      TargetArch
    hostOs         <- chooseSetting HostOs        TargetOs
    hostVendor     <- chooseSetting HostVendor    TargetVendor
    targetPlatform <- getSetting TargetPlatform
    targetArch     <- getSetting TargetArch
    llvmTarget     <- getSetting LlvmTarget
    targetOs       <- getSetting TargetOs
    targetVendor   <- getSetting TargetVendor
    return $ unlines
        [ "#ifndef __PLATFORM_H__"
        , "#define __PLATFORM_H__"
        , ""
        , "#define BuildPlatform_NAME  " ++ show buildPlatform
        , "#define HostPlatform_NAME   " ++ show hostPlatform
        , "#define TargetPlatform_NAME " ++ show targetPlatform
        , ""
        , "#define " ++ cppify buildPlatform  ++ "_BUILD 1"
        , "#define " ++ cppify hostPlatform   ++ "_HOST 1"
        , "#define " ++ cppify targetPlatform ++ "_TARGET 1"
        , ""
        , "#define " ++ buildArch  ++ "_BUILD_ARCH 1"
        , "#define " ++ hostArch   ++ "_HOST_ARCH 1"
        , "#define " ++ targetArch ++ "_TARGET_ARCH 1"
        , "#define BUILD_ARCH "  ++ show buildArch
        , "#define HOST_ARCH "   ++ show hostArch
        , "#define TARGET_ARCH " ++ show targetArch
        , "#define LLVM_TARGET " ++ show llvmTarget
        , ""
        , "#define " ++ buildOs  ++ "_BUILD_OS 1"
        , "#define " ++ hostOs   ++ "_HOST_OS 1"
        , "#define " ++ targetOs ++ "_TARGET_OS 1"
        , "#define BUILD_OS "  ++ show buildOs
        , "#define HOST_OS "   ++ show hostOs
        , "#define TARGET_OS " ++ show targetOs
        , ""
        , "#define " ++ buildVendor  ++ "_BUILD_VENDOR 1"
        , "#define " ++ hostVendor   ++ "_HOST_VENDOR 1"
        , "#define " ++ targetVendor ++ "_TARGET_VENDOR  1"
        , "#define BUILD_VENDOR "  ++ show buildVendor
        , "#define HOST_VENDOR "   ++ show hostVendor
        , "#define TARGET_VENDOR " ++ show targetVendor
        , ""
        , "#endif /* __PLATFORM_H__ */" ]

-- | Generate @ghcversion.h@ header.
generateGhcVersionH :: Expr String
generateGhcVersionH = do
    trackGenerateHs
    version     <- getSetting ProjectVersionInt
    patchLevel1 <- getSetting ProjectPatchLevel1
    patchLevel2 <- getSetting ProjectPatchLevel2
    return . unlines $
        [ "#ifndef __GHCVERSION_H__"
        , "#define __GHCVERSION_H__"
        , ""
        , "#ifndef __GLASGOW_HASKELL__"
        , "# define __GLASGOW_HASKELL__ " ++ version
        , "#endif"
        , ""]
        ++
        [ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
        ++
        [ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
        ++
        [ ""
        , "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
        , "   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \\"
        , "   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \\"
        , "          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
        , "   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \\"
        , "          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
        , "          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
        , ""
        , "#endif /* __GHCVERSION_H__ */" ]

-- | Generate @Version.hs@ files.
generateVersionHs :: Expr String
generateVersionHs = do
    trackGenerateHs
    projectVersion <- getSetting ProjectVersion
    targetOs       <- getSetting TargetOs
    targetArch     <- getSetting TargetArch
    return $ unlines
        [ "module Version where"
        , "version, targetOS, targetARCH :: String"
        , "version    = " ++ show projectVersion
        , "targetOS   = " ++ show targetOs
        , "targetARCH = " ++ show targetArch ]