module Rules (buildRules, oracleRules, packageTargets, topLevelTargets) where

import qualified Hadrian.Oracles.ArgsHash
import qualified Hadrian.Oracles.Cabal.Rules
import qualified Hadrian.Oracles.DirectoryContents
import qualified Hadrian.Oracles.Path
import qualified Hadrian.Oracles.TextFile

import Expression
import qualified Oracles.ModuleFiles
import Packages
import qualified Rules.BinaryDist
import qualified Rules.Compile
import qualified Rules.Configure
import qualified Rules.Dependencies
import qualified Rules.Documentation
import qualified Rules.Generate
import qualified Rules.Gmp
import qualified Rules.Libffi
import qualified Rules.Library
import qualified Rules.Program
import qualified Rules.Register
import qualified Rules.SimpleTargets
import Settings
import Target
import UserSettings
import Utilities

allStages :: [Stage]
allStages = [minBound .. maxBound]

-- | This rule calls 'need' on all top-level build targets that Hadrian builds
-- by default, respecting the 'finalStage' flag.
topLevelTargets :: Rules ()
topLevelTargets = action $ do
    verbosity <- getVerbosity
    forM_ [ Stage1 ..] $ \stage -> do
      when (verbosity >= Loud) $ do
        (libraries, programs) <- partition isLibrary <$> stagePackages stage
        libNames <- mapM (name stage) libraries
        pgmNames <- mapM (name stage) programs
        let stageHeader t ps =
              "| Building " ++ show stage ++ " "
                            ++ t ++ ": " ++ intercalate ", " ps
        putNormal . unlines $
            [ stageHeader "libraries" libNames
            , stageHeader "programs" pgmNames ]
    let buildStages = [ s | s <- [Stage0 ..], s < finalStage ]
    targets <- concatForM buildStages $ \stage -> do
        packages <- stagePackages stage
        mapM (path stage) packages
    need targets
  where
    -- either the package database config file for libraries or
    -- the programPath for programs. However this still does
    -- not support multiple targets, where a cabal package has
    -- a library /and/ a program.
    path :: Stage -> Package -> Action FilePath
    path stage pkg | isLibrary pkg = pkgConfFile (vanillaContext stage pkg)
                   | otherwise     = programPath =<< programContext stage pkg
    name :: Stage -> Package -> Action String
    name stage pkg | isLibrary pkg = return (pkgName pkg)
                   | otherwise     = programName (vanillaContext stage pkg)

-- TODO: Get rid of the @includeGhciLib@ hack.
-- | Return the list of targets associated with a given 'Stage' and 'Package'.
-- By setting the Boolean parameter to False it is possible to exclude the GHCi
-- library from the targets, and avoid configuring the package to determine
-- whether GHCi library needs to be built for it. We typically want to set
-- this parameter to True, however it is important to set it to False when
-- computing 'topLevelTargets', as otherwise the whole build gets sequentialised
-- because packages are configured in the order respecting their dependencies.
packageTargets :: Bool -> Stage -> Package -> Action [FilePath]
packageTargets includeGhciLib stage pkg = do
    let context = vanillaContext stage pkg
    activePackages <- stagePackages stage
    if pkg `notElem` activePackages
    then return [] -- Skip inactive packages.
    else if isLibrary pkg
        then do -- Collect all targets of a library package.
            let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
            ways  <- interpretInContext context pkgWays
            libs  <- mapM (pkgLibraryFile . Context stage pkg) ways
            more  <- libraryTargets includeGhciLib context
            setupConfig <- pkgSetupConfigFile context
            return $ [setupConfig] ++ libs ++ more
        else do -- The only target of a program package is the executable.
            prgContext <- programContext stage pkg
            prgPath    <- programPath prgContext
            return [prgPath]

packageRules :: Rules ()
packageRules = do
    -- We cannot register multiple GHC packages in parallel. Also we cannot run
    -- GHC when the package database is being mutated by "ghc-pkg". This is a
    -- classic concurrent read exclusive write (CREW) conflict.
    let maxConcurrentReaders = 1000
    packageDb <- newResource "package-db" maxConcurrentReaders
    let readPackageDb  = [(packageDb, 1)]
        writePackageDb = [(packageDb, maxConcurrentReaders)]

    Rules.Compile.compilePackage readPackageDb
    Rules.Dependencies.buildPackageDependencies readPackageDb
    Rules.Documentation.buildPackageDocumentation
    Rules.Program.buildProgramRules readPackageDb
    Rules.Register.configurePackageRules

    forM_ [Stage0 ..] (Rules.Register.registerPackageRules writePackageDb)

    -- TODO: Can we get rid of this enumeration of contexts? Since we iterate
    --       over it to generate all 4 types of rules below, all the time, we
    --       might want to see whether the parse-and-extract approach of
    --       Rules.Compile and Rules.Library could save us some time there.
    let vanillaContexts = liftM2 vanillaContext allStages knownPackages

    forM_ vanillaContexts Rules.Generate.generatePackageCode
    Rules.SimpleTargets.simplePackageTargets

buildRules :: Rules ()
buildRules = do
    Rules.BinaryDist.bindistRules
    Rules.Configure.configureRules
    Rules.Generate.copyRules
    Rules.Generate.generateRules
    Rules.Gmp.gmpRules
    Rules.Libffi.libffiRules
    Rules.Library.libraryRules
    packageRules

oracleRules :: Rules ()
oracleRules = do
    Hadrian.Oracles.ArgsHash.argsHashOracle trackArgument getArgs
    Hadrian.Oracles.Cabal.Rules.cabalOracle
    Hadrian.Oracles.DirectoryContents.directoryContentsOracle
    Hadrian.Oracles.Path.pathOracle
    Hadrian.Oracles.TextFile.textFileOracle
    Oracles.ModuleFiles.moduleFilesOracle


module Settings (
    getArgs, getLibraryWays, getRtsWays, flavour, knownPackages,
    findPackageByName, unsafeFindPackageByName, unsafeFindPackageByPath,
    isLibrary, stagePackages, programContext, getIntegerPackage
    ) where

import CommandLine
import Expression
import Flavour
import Packages
import UserSettings (userFlavours, userPackages, userDefaultFlavour)

import {-# SOURCE #-} Settings.Default
import Settings.Flavours.Development
import Settings.Flavours.Llvm
import Settings.Flavours.Performance
import Settings.Flavours.Profiled
import Settings.Flavours.Quick
import Settings.Flavours.Quickest
import Settings.Flavours.QuickCross

getArgs :: Args
getArgs = expr flavour >>= args

getLibraryWays :: Ways
getLibraryWays = expr flavour >>= libraryWays

getRtsWays :: Ways
getRtsWays = expr flavour >>= rtsWays

stagePackages :: Stage -> Action [Package]
stagePackages stage = do
    f <- flavour
    packages f stage

hadrianFlavours :: [Flavour]
hadrianFlavours =
    [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
    , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour
    , quickCrossFlavour
    , performanceLlvmFlavour, profiledLlvmFlavour, quickLlvmFlavour ]

flavour :: Action Flavour
flavour = do
    flavourName <- fromMaybe userDefaultFlavour <$> cmdFlavour
    let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
        flavours       = hadrianFlavours ++ userFlavours
    return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours

getIntegerPackage :: Expr Package
getIntegerPackage = expr (integerLibrary =<< flavour)

-- TODO: there is duplication and inconsistency between this and
-- Rules.Program.getProgramContexts. There should only be one way to get a
-- context / contexts for a given stage and package.
programContext :: Stage -> Package -> Action Context
programContext stage pkg = do
    profiled <- ghcProfiled <$> flavour
    dynGhcProgs <- dynamicGhcPrograms =<< flavour
    return . Context stage pkg . wayFromUnits . concat $
        [ [ Profiling  | pkg == ghc && profiled && stage > Stage0 ]
        , [ Dynamic    | dynGhcProgs && stage > Stage0 ]
        ]

-- TODO: switch to Set Package as the order of packages should not matter?
-- Otherwise we have to keep remembering to sort packages from time to time.
knownPackages :: [Package]
knownPackages = sort $ ghcPackages ++ userPackages

-- TODO: Speed up? Switch to Set?
-- Note: this is slow but we keep it simple as there are just ~50 packages
findPackageByName :: PackageName -> Maybe Package
findPackageByName name = find (\pkg -> pkgName pkg == name) knownPackages

unsafeFindPackageByName :: PackageName -> Package
unsafeFindPackageByName name = fromMaybe (error msg) $ findPackageByName name
  where
    msg = "unsafeFindPackageByName: No package with name " ++ name

unsafeFindPackageByPath :: FilePath -> Package
unsafeFindPackageByPath path = err $ find (\pkg -> pkgPath pkg == path) knownPackages
  where
    err = fromMaybe $ error ("findPackageByPath: No package for path " ++ path)


module Stage (Stage (..), stageString) where

import Development.Shake.Classes
import GHC.Generics

-- | A stage refers to a certain compiler in GHC's build process.
--
-- * Stage 0 is built with the bootstrapping compiler, i.e. the one already
--   installed on the user's system. The compiler that is produced during
--   stage 0 is called /stage 1 compiler/.
--
-- * Stage 1 is built using the stage 1 compiler and all GHC sources. The result
--   is called /stage 2 compiler/ and it has all features of the new GHC.
--
-- * Stage 2 is built using the stage 2 compiler. The result is a compiler
--   fully "built by itself", commonly referred to as /bootstrapping/.
--
-- * Stage 3 is built as a self test. The resulting compiler should have
--   the same object code as the one built in stage 2, which is a good test
--   for the compiler. Since it serves no other purpose than that, the stage 3
--   build is usually omitted in the build process.
data Stage = Stage0 | Stage1 | Stage2 | Stage3
    deriving (Show, Eq, Ord, Enum, Generic, Bounded)

instance Binary   Stage
instance Hashable Stage
instance NFData   Stage

-- | Prettyprint a 'Stage'.
stageString :: Stage -> String
stageString stage = "stage" ++ show (fromEnum stage)


module Target (
    Target, target, context, builder, inputs, outputs, trackArgument,
    module Builder
    ) where

import Data.Char
import Data.List.Extra

import qualified Hadrian.Target as H
import Hadrian.Target hiding (Target)

import Builder
import Context

type Target = H.Target Context Builder

-- | Some arguments do not affect build results and therefore do not need to be
-- tracked by the build system. A notable example is "-jN" that controls Make's
-- parallelism. Given a 'Target' and an argument, this function should return
-- 'True' only if the argument needs to be tracked.
trackArgument :: Target -> String -> Bool
trackArgument target arg = case builder target of
    (Make _) -> not $ threadArg arg
    _        -> True
  where
    threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]


-- If you want to customise your build you should copy this file from
-- hadrian/src/UserSettings.hs to hadrian/UserSettings.hs and edit your copy.
-- If you don't copy the file your changes will be tracked by git and you can
-- accidentally commit them.
--
-- See doc/user-settings.md for instructions, and src/Flavour.hs for auxiliary
-- functions for manipulating flavours.
-- Please update doc/user-settings.md when committing changes to this file.
module UserSettings (
    userFlavours, userPackages, userDefaultFlavour,
    verboseCommand, buildProgressColour, successColour, finalStage
    ) where

import Flavour
import Expression
import {-# SOURCE #-} Settings.Default

-- See doc/user-settings.md for instructions.
-- Please update doc/user-settings.md when committing changes to this file.

-- | Name of the default flavour, i.e the one used when no --flavour=<name>
--   argument is passed to Hadrian.
userDefaultFlavour :: String
userDefaultFlavour = "default"

-- | User-defined build flavours. See 'userFlavour' as an example.
userFlavours :: [Flavour]
userFlavours = [userFlavour] -- Add more build flavours if need be.

-- | This is an example user-defined build flavour. Feel free to modify it and
-- use by passing @--flavour=user@ from the command line.
userFlavour :: Flavour
userFlavour = defaultFlavour { name = "user" } -- Modify other settings here.

-- | Add user-defined packages. Note, this only lets Hadrian know about the
-- existence of a new package; to actually build it you need to create a new
-- build flavour, modifying the list of packages that are built by default.
userPackages :: [Package]
userPackages = []

-- | Set to 'True' to print full command lines during the build process. Note:
-- this is a 'Predicate', hence you can enable verbose output only for certain
-- targets, e.g.: @verboseCommand = package ghcPrim@.
verboseCommand :: Predicate
verboseCommand = do
    verbosity <- expr getVerbosity
    return $ verbosity >= Loud

-- | Set colour for build progress messages (e.g. executing a build command).
buildProgressColour :: BuildProgressColour
buildProgressColour = mkBuildProgressColour (Dull Magenta)

-- | Set colour for success messages (e.g. a package is built successfully).
successColour :: SuccessColour
successColour = mkSuccessColour (Dull Green)

-- | Stop after building the StageN compiler.
-- For example, setting the 'finalStage' to 'Stage1' will just build the
-- 'Stage1' compiler. Setting it to 'Stage3' will build the 'Stage3'
-- compiler. Setting it to 'Stage0' will mean nothing gets built at all.
finalStage :: Stage
finalStage = Stage2


module Utilities (
    build, buildWithResources, buildWithCmdOptions,
    askWithResources,
    runBuilder, runBuilderWith,
    needLibrary, contextDependencies, stage1Dependencies, libraryTargets,
    topsortPackages, cabalDependencies
    ) where

import qualified Hadrian.Builder as H
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
import Hadrian.Utilities

import Context
import Expression hiding (stage)
import Settings
import Target

build :: Target -> Action ()
build target = H.build target getArgs

buildWithResources :: [(Resource, Int)] -> Target -> Action ()
buildWithResources rs target = H.buildWithResources rs target getArgs

buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
buildWithCmdOptions opts target = H.buildWithCmdOptions opts target getArgs

askWithResources :: [(Resource, Int)] -> Target -> Action String
askWithResources rs target = H.askWithResources rs target getArgs

-- TODO: Cache the computation.
-- | Given a 'Context' this 'Action' looks up the package dependencies and wraps
-- the results in appropriate contexts.
-- To compute package dependencies we transitively scan Cabal files using
-- 'pkgDependencies' defined in "Hadrian.Haskell.Cabal".
contextDependencies :: Context -> Action [Context]
contextDependencies Context {..} = do
    depPkgs <- go [package]
    return [ Context stage pkg way | pkg <- depPkgs, pkg /= package ]
  where
    go pkgs  = do
        deps <- concatMapM step pkgs
        let newPkgs = nubOrd $ sort (deps ++ pkgs)
        if pkgs == newPkgs then return pkgs else go newPkgs
    step pkg = do
        deps   <- pkgDependencies pkg
        active <- sort <$> stagePackages stage
        return $ intersectOrd (compare . pkgName) active deps

cabalDependencies :: Context -> Action [String]
cabalDependencies ctx = interpretInContext ctx $ getContextData depIds

-- | Lookup dependencies of a 'Package' in the @vanilla Stage1 context@.
stage1Dependencies :: Package -> Action [Package]
stage1Dependencies =
    fmap (map Context.package) . contextDependencies . vanillaContext Stage1

-- | Given a library 'Package' this action computes all of its targets. See
-- 'packageTargets' for the explanation of the @includeGhciLib@ parameter.
libraryTargets :: Bool -> Context -> Action [FilePath]
libraryTargets includeGhciLib context@Context {..} = do
    libFile  <- pkgLibraryFile     context
    ghciLib  <- pkgGhciLibraryFile context
    ghci     <- if includeGhciLib && not (wayUnit Dynamic way)
                then interpretInContext context $ getContextData buildGhciLib
                else return False
    return $ [ libFile ] ++ [ ghciLib | ghci ]

-- | Coarse-grain 'need': make sure all given libraries are fully built.
needLibrary :: [Context] -> Action ()
needLibrary cs = need =<< concatMapM (libraryTargets True) cs

-- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
-- | Topological sort of packages according to their dependencies.
topsortPackages :: [Package] -> Action [Package]
topsortPackages pkgs = do
    elems <- mapM (\p -> (p,) <$> stage1Dependencies p) pkgs
    return $ map fst $ topSort elems
  where
    annotateInDeg es e =
     (foldr (\e' s -> if fst e' `elem` snd e then s + 1 else s) (0 :: Int) es, e)
    topSort [] = []
    topSort es =
      let annotated = map (annotateInDeg es) es
          inDegZero = map snd $ filter ((== 0). fst) annotated
      in  inDegZero ++ topSort (es \\ inDegZero)


module Way (
    WayUnit (..), Way, wayUnit, addWayUnit, removeWayUnit, wayFromUnits, allWays,

    vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging,
    threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
    threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
    threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic,

    wayPrefix, waySuffix, hisuf, osuf, hcsuf, obootsuf, hibootsuf, ssuf
    ) where

import Way.Type

-- | Build default _vanilla_ way.
vanilla :: Way
vanilla = wayFromUnits []

-- | Build with profiling.
profiling :: Way
profiling = wayFromUnits [Profiling]

-- | Build with dynamic linking.
dynamic :: Way
dynamic = wayFromUnits [Dynamic]

-- | Build with profiling and dynamic linking.
profilingDynamic :: Way
profilingDynamic = wayFromUnits [Profiling, Dynamic]

-- RTS only ways below. See compiler/main/DynFlags.hs.
-- | Build RTS with event logging.
logging :: Way
logging = wayFromUnits [Logging]

-- | Build multithreaded RTS.
threaded :: Way
threaded = wayFromUnits [Threaded]

-- | Build RTS with debug information.
debug :: Way
debug = wayFromUnits [Debug]

-- | Various combinations of RTS only ways.
threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
    threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic,
    threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic :: Way
threadedDebug            = wayFromUnits [Threaded, Debug]
threadedProfiling        = wayFromUnits [Threaded, Profiling]
threadedLogging          = wayFromUnits [Threaded, Logging]
threadedDynamic          = wayFromUnits [Threaded, Dynamic]
threadedDebugProfiling   = wayFromUnits [Threaded, Debug, Profiling]
threadedDebugDynamic     = wayFromUnits [Threaded, Debug, Dynamic]
threadedProfilingDynamic = wayFromUnits [Threaded, Profiling, Dynamic]
threadedLoggingDynamic   = wayFromUnits [Threaded, Logging, Dynamic]
debugProfiling           = wayFromUnits [Debug, Profiling]
debugDynamic             = wayFromUnits [Debug, Dynamic]
loggingDynamic           = wayFromUnits [Logging, Dynamic]

-- | All ways supported by the build system.
allWays :: [Way]
allWays =
    [ vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging
    , threadedDebug, threadedProfiling, threadedLogging, threadedDynamic
    , threadedDebugProfiling, threadedDebugDynamic, threadedProfilingDynamic
    , threadedLoggingDynamic, debugProfiling, debugDynamic, loggingDynamic ]

wayPrefix :: Way -> String
wayPrefix way | way == vanilla = ""
              | otherwise      = show way ++ "_"

waySuffix :: Way -> String
waySuffix way | way == vanilla = ""
              | otherwise      = "_" ++ show way

osuf, ssuf, hisuf, hcsuf, obootsuf, hibootsuf :: Way -> String
osuf      = (++ "o"      ) . wayPrefix
ssuf      = (++ "s"      ) . wayPrefix
hisuf     = (++ "hi"     ) . wayPrefix
hcsuf     = (++ "hc"     ) . wayPrefix
obootsuf  = (++ "o-boot" ) . wayPrefix
hibootsuf = (++ "hi-boot") . wayPrefix


module Context.Path where

import Base
import Context.Type
import Hadrian.Expression

-- | The build directory of the current 'Stage'.
stageDir :: Context -> FilePath
stageDir Context {..} = stageString stage

-- | The build path of the current 'Stage'.
stagePath :: Context -> Action FilePath
stagePath context = buildRoot <&> (-/- stageDir context)

-- | The expression that evaluates to the build path of the current 'Stage'.
getStagePath :: Expr Context b FilePath
getStagePath = expr . stagePath =<< getContext

-- | The directory in 'buildRoot' containing build artifacts of a given 'Context'.
contextDir :: Context -> FilePath
contextDir Context {..} = stageString stage -/- pkgPath package

-- | The path to the directory in 'buildRoot' containing build artifacts of a
-- given 'Context'.
contextPath :: Context -> Action FilePath
contextPath context = buildRoot <&> (-/- contextDir context)

-- | The expression that evaluates to the path to the directory in 'buildRoot'
-- containing build artifacts of a given 'Context'.
getContextPath :: Expr Context b FilePath
getContextPath = expr . contextPath =<< getContext

-- | The directory in 'buildRoot' containing the object artifacts.
buildDir :: Context -> FilePath
buildDir context = contextDir context -/- "build"

-- | Path to the directory containing build artifacts of a given 'Context'.
buildPath :: Context -> Action FilePath
buildPath context = buildRoot <&> (-/- buildDir context)

-- | The expression that evaluates to the build path of the current 'Context'.
getBuildPath :: Expr Context b FilePath
getBuildPath = expr . buildPath =<< getContext


module Context.Type where

import Development.Shake.Classes
import GHC.Generics
import Hadrian.Package

import Stage
import Way.Type

-- | Build context for a currently built 'Target'. We generate potentially
-- different build rules for each 'Context'.
data Context = Context
    { stage   :: Stage   -- ^ Currently build Stage
    , package :: Package -- ^ Currently build Package
    , way     :: Way     -- ^ Currently build Way (usually 'vanilla')
    } deriving (Eq, Generic, Show)

instance Binary   Context
instance Hashable Context
instance NFData   Context


module Expression.Type where

import Context.Type
import Way.Type

import Builder
import qualified Hadrian.Expression as H

-- | @Expr a@ is a computation that produces a value of type @Action a@ and can
-- read parameters of the current build 'Target'.
type Expr a = H.Expr Context Builder a

-- | The following expressions are used throughout the build system for
-- specifying conditions ('Predicate'), lists of arguments ('Args'), 'Ways'
-- and 'Packages'.
type Predicate = H.Predicate Context Builder
type Args      = H.Args      Context Builder
type Ways      = Expr [Way]


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Builder
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- A typical build system invokes several build tools, or /builders/, such as
-- compilers, linkers, etc., some of which may be built by the build system
-- itself. This module defines the 'Builder' type class and a few associated
-- functions that can be used to invoke builders.
-----------------------------------------------------------------------------
module Hadrian.Builder (
    Builder (..), BuildInfo (..), needBuilder, runBuilder,
    runBuilderWithCmdOptions, build, buildWithResources, buildWithCmdOptions,
    getBuilderPath, builderEnvironment, askWithResources
    ) where

import Data.List
import Development.Shake

import Hadrian.Expression hiding (inputs, outputs)
import Hadrian.Oracles.ArgsHash
import Hadrian.Target
import Hadrian.Utilities

-- | This data structure captures all information relevant to invoking a builder.
data BuildInfo = BuildInfo {
    -- | Command line arguments.
    buildArgs :: [String],
    -- | Input files.
    buildInputs :: [FilePath],
    -- | Output files.
    buildOutputs :: [FilePath],
    -- | Options to be passed to Shake's 'cmd' function.
    buildOptions :: [CmdOption],
    -- | Resources to be aquired.
    buildResources :: [(Resource, Int)] }

class ShakeValue b => Builder b where
    -- | The path to a builder.
    builderPath :: b -> Action FilePath

    -- | Ask the builder for information.
    -- E.g. ask @ghc-pkg@ for package dependencies
    -- capture the @stdout@ result and return it.
    askBuilderWith :: b -> BuildInfo -> Action String

    -- | Runtime dependencies of a builder. For example, on Windows GHC requires
    -- the utility @touchy.exe@ to be avilable on a specific path.
    runtimeDependencies :: b -> Action [FilePath]
    runtimeDependencies _ = return []

    -- | Run a builder with a given 'BuildInfo'. Also see 'runBuilder'.
    runBuilderWith :: b -> BuildInfo -> Action ()
    runBuilderWith builder buildInfo = do
        let args = buildArgs buildInfo
        needBuilder builder
        path <- builderPath builder
        let msg = if null args then "" else " (" ++ intercalate ", " args ++ ")"
        putBuild $ "| Run " ++ show builder ++ msg
        quietly $ cmd (buildOptions buildInfo) [path] args

-- | Make sure a builder and its runtime dependencies are up-to-date.
needBuilder :: Builder b => b -> Action ()
needBuilder builder = do
    path <- builderPath builder
    deps <- runtimeDependencies builder
    need (path : deps)

-- | Run a builder with a specified list of command line arguments, reading a
-- list of input files and writing a list of output files. A lightweight version
-- of 'runBuilderWith'.
runBuilder :: Builder b => b -> [String] -> [FilePath] -> [FilePath] -> Action ()
runBuilder = runBuilderWithCmdOptions []

-- | Like 'runBuilder' but passes given options to Shake's 'cmd'.
runBuilderWithCmdOptions :: Builder b => [CmdOption] -> b -> [String] -> [FilePath] -> [FilePath] -> Action ()
runBuilderWithCmdOptions opts builder args inputs outputs =
    runBuilderWith builder $ BuildInfo { buildArgs      = args
                                       , buildInputs    = inputs
                                       , buildOutputs   = outputs
                                       , buildOptions   = opts
                                       , buildResources = [] }

-- | Build a 'Target' using the list of command line arguments computed from a
-- given 'Args' expression. Force a rebuild if the argument list has changed
-- since the last build.
build :: (Builder b, ShakeValue c) => Target c b -> Args c b -> Action ()
build = buildWith [] []

-- | Like 'build' but acquires necessary resources.
buildWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action ()
buildWithResources rs = buildWith rs []

askWithResources :: (Builder b, ShakeValue c) => [(Resource, Int)] -> Target c b -> Args c b -> Action String
askWithResources rs = askWith rs []

-- | Like 'build' but passes given options to Shake's 'cmd'.
buildWithCmdOptions :: (Builder b, ShakeValue c) => [CmdOption] -> Target c b -> Args c b -> Action ()
buildWithCmdOptions = buildWith []

doWith :: (Builder b, ShakeValue c)
       => (b -> BuildInfo -> Action a)
       -> (Target c b -> Action ())
       -> [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action a
doWith f info rs opts target args = do
    needBuilder (builder target)
    argList <- interpret target args
    trackArgsHash target -- Rerun the rule if the hash of argList has changed.
    info target
    verbose <- interpret target verboseCommand
    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
    quietlyUnlessVerbose $ f (builder target) $
        BuildInfo { buildArgs      = argList
                  , buildInputs    = inputs target
                  , buildOutputs   = outputs target
                  , buildOptions   = opts
                  , buildResources = rs }

buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action ()
buildWith = doWith runBuilderWith runInfo

askWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action String
askWith = doWith askBuilderWith askInfo

-- | Print out information about the command being executed.
runInfo :: Show b => Target c b -> Action ()
runInfo t = putProgressInfo =<< renderAction
    ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo.
    (digest $ inputs  t)
    (digest $ outputs t)
  where
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"

askInfo :: Show b => Target c b -> Action ()
askInfo t = putProgressInfo =<< renderActionNoOutput
    ("Run " ++ show (builder t)) -- TODO: Bring back contextInfo.
    (digest $ inputs  t)
  where
    digest [] = "none"
    digest [x] = x
    digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"

-- | Get the path to the current builder.
getBuilderPath :: Builder b => b -> Expr c b FilePath
getBuilderPath = expr . builderPath

-- | Write a builder path into a given environment variable.
builderEnvironment :: Builder b => String -> b -> Action CmdOption
builderEnvironment variable builder = do
    needBuilder builder
    path <- builderPath builder
    return $ AddEnv variable path


module Hadrian.BuildPath where

import Base

import Data.Functor
import qualified Text.Parsec as Parsec

-- | A path of the form
--
-- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
--
-- where @something@ describes a library or object file or ... to be built
-- for the given package.
--
-- @a@, which represents that @something@, is instantiated with library-related
-- data types in @Rules.Library@ and with object/interface files related types
-- in @Rules.Compile@.
data BuildPath a = BuildPath FilePath -- ^ > <build root>/
                             Stage    -- ^ > stage<N>/
                             FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
                             a        -- ^ > whatever comes after 'build/'
    deriving (Eq, Show)

-- | Parse a build path under the given build root.
parseBuildPath
    :: FilePath -- ^ build root
    -> Parsec.Parsec String () a -- ^ what to parse after @build/@
    -> Parsec.Parsec String () (BuildPath a)
parseBuildPath root afterBuild = do
    _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
    stage <- parseStage
    _ <- Parsec.char '/'
    pkgpath <- Parsec.manyTill Parsec.anyChar
        (Parsec.try $ Parsec.string "/build/")
    a <- afterBuild
    return (BuildPath root stage pkgpath a)

-- To be kept in sync with Stage.hs's stageString function
-- | Parse @"stageX"@ into a 'Stage'.
parseStage :: Parsec.Parsec String () Stage
parseStage = (Parsec.string "stage" *> Parsec.choice
    [ Parsec.string (show n) $> toEnum n
    | n <- map fromEnum [minBound .. maxBound :: Stage]
    ]) Parsec.<?> "stage string"

-- To be kept in sync with the show instances in 'Way.Type', until we perhaps
-- use some bidirectional parsing/pretty printing approach or library.
-- | Parse a way suffix, returning the argument when no suffix is found (the
-- argument will be vanilla in most cases, but dynamic when we parse the way
-- suffix out of a shared library file name).
parseWaySuffix :: Way -> Parsec.Parsec String () Way
parseWaySuffix w = Parsec.choice
    [ Parsec.char '_' *>
        (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.char '_'))
    , pure w
    ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"

-- | Same as 'parseWaySuffix', but for parsing e.g @thr_p_@
--   instead of @_thr_p@, like 'parseWaySuffix' does.
--
--   This is used to parse paths to object files,
--   in Rules.Compile.
parseWayPrefix :: Way -> Parsec.Parsec String () Way
parseWayPrefix w = Parsec.choice
    [ wayFromUnits <$> Parsec.endBy1 parseWayUnit (Parsec.char '_')
    , pure w
    ] Parsec.<?> "way prefix (e.g thr_p_, or none for vanilla)"

parseWayUnit :: Parsec.Parsec String () WayUnit
parseWayUnit = Parsec.choice
    [ Parsec.string "thr" *> pure Threaded
    , Parsec.char   'd'   *>
      (Parsec.choice [ Parsec.string "ebug" *> pure Debug
                     , Parsec.string "yn"   *> pure Dynamic ])
    , Parsec.char 'p'     *> pure Profiling
    , Parsec.char 'l'     *> pure Logging
    ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"

-- | Parse a @"pkgname-pkgversion"@ string into the package name and the
-- integers that make up the package version.
parsePkgId :: Parsec.Parsec String () (String, [Integer])
parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
  where
    parsePkgId' currName = do
        s <- Parsec.many1 Parsec.alphaNum
        _ <- Parsec.char '-'
        let newName = if null currName then s else currName ++ "-" ++ s
        Parsec.choice [ (newName,) <$> parsePkgVersion
                      , parsePkgId' newName ]

-- | Parse "."-separated integers that describe a package's version.
parsePkgVersion :: Parsec.Parsec String () [Integer]
parsePkgVersion = fmap reverse (parsePkgVersion' [])
       Parsec.<?> "package version"
  where
    parsePkgVersion' xs = do
        n <- parseNatural
        Parsec.choice
            [ Parsec.try
                  (Parsec.lookAhead (Parsec.char '.' *>
                                        (Parsec.letter <|> Parsec.char '_')
                                    )
                  )
              $> (n:xs)
            , Parsec.char '.' *> parsePkgVersion' (n:xs)
            , pure $ (n:xs) ]

-- | Parse a natural number.
parseNatural :: Parsec.Parsec String () Integer
parseNatural = (read <$> Parsec.many1 Parsec.digit) Parsec.<?> "natural number"

-- | Runs the given parser against the given path, erroring out when the parser
-- fails (because it shouldn't if the code from this module is correct).
parsePath
    :: Parsec.Parsec String () a -- ^ parser to run
    -> String                    -- ^ string describing the input source
    -> FilePath                  -- ^ path to parse
    -> Action a
parsePath p inp path = case Parsec.parse p inp path of
    Left err -> fail $ "Hadrian.BuildPath.parsePath: path="
                    ++ path ++ ", error:\n" ++ show err
    Right a  -> pure a


{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
module Hadrian.Expression (
    -- * Expressions
    Expr, Predicate, Args,

    -- ** Construction and modification
    expr, exprIO, arg, remove,

    -- ** Predicates
    (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,

    -- ** Evaluation
    interpret, interpretInContext,

    -- * Convenient accessors
    getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
    ) where

import Control.Monad.Extra
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Development.Shake
import Development.Shake.Classes

import qualified Hadrian.Target as Target
import Hadrian.Target (Target, target)
import Hadrian.Utilities

-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
newtype Expr c b a = Expr (ReaderT (Target c b) Action a)
    deriving (Applicative, Functor, Monad)

instance Semigroup a => Semigroup (Expr c b a) where
    Expr x <> Expr y = Expr $ (<>) <$> x <*> y

-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where
    mempty  = pure mempty
    mappend = (<>)

-- | Expressions that compute a Boolean value.
type Predicate c b = Expr c b Bool

-- | Expressions that compute lists of arguments to be passed to builders.
type Args c b = Expr c b [String]

-- | Lift actions independent from the current build 'Target' into the 'Expr'
-- monad.
expr :: Action a -> Expr c b a
expr = Expr . lift

-- | Lift IO computations independent from the current build 'Target' into the
-- 'Expr' monad.
exprIO :: IO a -> Expr c b a
exprIO = Expr . liftIO

-- | Remove given elements from a list expression.
remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a]
remove xs e = filter (`notElem` xs) <$> e

-- | Add a single argument to 'Args'.
arg :: String -> Args c b
arg = pure . pure

-- | Values that can be converted to a 'Predicate'.
class ToPredicate p c b where
    toPredicate :: p -> Predicate c b

infixr 3 ?

-- | Apply a predicate to an expression.
(?) :: (Monoid a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a
p ? e = do
    bool <- toPredicate p
    if bool then e else mempty

instance ToPredicate Bool c b where
    toPredicate = pure

instance ToPredicate p c b => ToPredicate (Action p) c b where
    toPredicate = toPredicate . expr

instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where
    toPredicate p = toPredicate =<< p

-- | Interpret a given expression according to the given 'Target'.
interpret :: Target c b -> Expr c b a -> Action a
interpret target (Expr e) = runReaderT e target

-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext :: c -> Expr c b a -> Action a
interpretInContext c = interpret $ target c
    (error "contextOnlyTarget: builder not set")
    (error "contextOnlyTarget: inputs not set" )
    (error "contextOnlyTarget: outputs not set")

-- | Get the directory of build results.
getBuildRoot :: Expr c b FilePath
getBuildRoot = expr buildRoot

-- | Get the current build 'Context'.
getContext :: Expr c b c
getContext = Expr $ asks Target.context

-- | Get the 'Builder' for the current 'Target'.
getBuilder :: Expr c b b
getBuilder = Expr $ asks Target.builder

-- | Get the input files of the current 'Target'.
getInputs :: Expr c b [FilePath]
getInputs = Expr $ asks Target.inputs

-- | Run 'getInputs' and check that the result contains one input file only.
getInput :: (Show b, Show c) => Expr c b FilePath
getInput = Expr $ do
    target <- ask
    fromSingleton ("Exactly one input file expected in " ++ show target) <$>
        asks Target.inputs

-- | Get the files produced by the current 'Target'.
getOutputs :: Expr c b [FilePath]
getOutputs = Expr $ asks Target.outputs

-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput :: (Show b, Show c) => Expr c b FilePath
getOutput = Expr $ do
    target <- ask
    fromSingleton ("Exactly one output file expected in " ++ show target) <$>
        asks Target.outputs

-- | Does any of the input files match a given pattern?
input :: FilePattern -> Predicate c b
input f = any (f ?==) <$> getInputs

-- | Does any of the input files match any of the given patterns?
inputs :: [FilePattern] -> Predicate c b
inputs = anyM input

-- | Does any of the output files match a given pattern?
output :: FilePattern -> Predicate c b
output f = any (f ?==) <$> getOutputs

-- | Does any of the output files match any of the given patterns?
outputs :: [FilePattern] -> Predicate c b
outputs = anyM output

newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
    deriving Typeable

verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Package
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- A /package/ is a collection of files. We currently only support C and Haskell
-- packages and treat a package as either a library or a program. The latter is
-- a gross oversimplification as, for example, Haskell packages can be both.
-- This works for now, but should be improved in future.
-----------------------------------------------------------------------------
module Hadrian.Package (
    -- * Data types
    Package (..), PackageName, PackageType,

    -- * Construction and properties
    library, program, dummyPackage, isLibrary, isProgram,

    -- * Package directory structure
    pkgCabalFile
    ) where

import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Generics

import Hadrian.Utilities

-- TODO: Make PackageType more precise.
-- See https://github.com/snowleopard/hadrian/issues/12.
data PackageType = Library | Program deriving (Eq, Generic, Ord, Show)

type PackageName = String

-- TODO: Consider turning Package into a GADT indexed with language and type.
data Package = Package {
    -- | The package type. 'Library' and 'Program' packages are supported.
    pkgType :: PackageType,
    -- | The package name. We assume that all packages have different names,
    -- hence two packages with the same name are considered equal.
    pkgName :: PackageName,
    -- | The path to the package source code relative to the root of the build
    -- system. For example, @libraries/Cabal/Cabal@ and @ghc@ are paths to the
    -- @Cabal@ and @ghc-bin@ packages in GHC.
    pkgPath :: FilePath
    } deriving (Eq, Generic, Ord, Show)

-- | Construct a library package.
library :: PackageName -> FilePath -> Package
library = Package Library

-- | Construct a program package.
program :: PackageName -> FilePath -> Package
program = Package Program

-- TODO: Remove this hack.
-- | A dummy package that we never try to build but use when we need a 'Package'
-- to construct a 'Context' but do not need to access the package field.
dummyPackage :: Package
dummyPackage = library "dummy" "dummy/path/"

-- | Is this a library package?
isLibrary :: Package -> Bool
isLibrary (Package Library _ _) = True
isLibrary _ = False

-- | Is this a program package?
isProgram :: Package -> Bool
isProgram (Package Program _ _) = True
isProgram _ = False

-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@.
pkgCabalFile :: Package -> FilePath
pkgCabalFile p = pkgPath p -/- pkgName p <.> "cabal"

instance Binary   PackageType
instance Hashable PackageType
instance NFData   PackageType

instance Binary   Package
instance Hashable Package
instance NFData   Package


module Hadrian.Target (Target, target, context, builder, inputs, outputs) where

import Development.Shake.Classes
import GHC.Generics

-- | Each invocation of a builder is fully described by a 'Target', which
-- comprises a build context (type variable @c@), a builder (type variable @b@),
-- a list of input files and a list of output files. For example:
--
-- @
-- preludeTarget = Target (GHC.Context) (GHC.Builder)
--     { context = Context Stage1 base profiling
--     , builder = Ghc Stage1
--     , inputs = ["libraries/base/Prelude.hs"]
--     , outputs = ["build/stage1/libraries/base/Prelude.p_o"] }
-- @
data Target c b = Target
    { context :: c          -- ^ Current build context
    , builder :: b          -- ^ Builder to be invoked
    , inputs  :: [FilePath] -- ^ Input files for the builder
    , outputs :: [FilePath] -- ^ Files to be produced
    } deriving (Eq, Generic, Show)

target :: c -> b -> [FilePath] -> [FilePath] -> Target c b
target = Target

instance (Binary   c, Binary   b) => Binary   (Target c b)
instance (Hashable c, Hashable b) => Hashable (Target c b)
instance (NFData   c, NFData   b) => NFData   (Target c b)


{-# LANGUAGE TypeFamilies #-}
module Hadrian.Utilities (
    -- * List manipulation
    fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,

    -- * String manipulation
    quote, yesNo, parseYesNo, zeroOne,

    -- * FilePath manipulation
    unifyPath, (-/-), makeRelativeNoSysLink,

    -- * Accessing Shake's type-indexed map
    insertExtra, lookupExtra, userSetting,

    -- * Paths
    BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,

    -- * File system operations
    copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
    createDirectory, copyDirectory, moveDirectory, removeDirectory,

    -- * Diagnostic info
    UseColour (..), Colour (..), ANSIColour (..), putColoured,
    BuildProgressColour, mkBuildProgressColour, putBuild,
    SuccessColour, mkSuccessColour, putSuccess,
    ProgressInfo (..), putProgressInfo,
    renderAction, renderActionNoOutput, renderProgram, renderLibrary, renderBox, renderUnicorn,

    -- * Miscellaneous
    (<&>), (%%>), cmdLineLengthLimit,

    -- * Useful re-exports
    Dynamic, fromDynamic, toDyn, TypeRep, typeOf
    ) where

import Control.Monad.Extra
import Data.Char
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.HashMap.Strict (HashMap)
import Data.List (isPrefixOf)
import Data.List.Extra
import Data.Maybe
import Data.Typeable (TypeRep, typeOf)
import Development.Shake hiding (Normal)
import Development.Shake.Classes
import Development.Shake.FilePath
import System.Environment (lookupEnv)
import System.Info.Extra

import qualified Control.Exception.Base as IO
import qualified Data.HashMap.Strict    as Map
import qualified System.Directory.Extra as IO
import qualified System.Info.Extra      as IO
import qualified System.IO              as IO

-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
fromSingleton :: String -> [a] -> a
fromSingleton _   [res] = res
fromSingleton msg _     = error msg

-- | Find and replace all occurrences of a value in a list.
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from to = map (\cur -> if cur == from then to else cur)

-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _  = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
    LT -> x : minusOrd xs (y:ys)
    EQ ->     minusOrd xs ys
    GT ->     minusOrd (x:xs) ys

-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
  where
    loop [] _ = []
    loop _ [] = []
    loop (x:xs) (y:ys) = case cmp x y of
        LT ->     loop xs (y:ys)
        EQ -> x : loop xs (y:ys)
        GT ->     loop (x:xs) ys

-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
lookupAll []     _      = []
lookupAll (_:xs) []     = Nothing : lookupAll xs []
lookupAll (x:xs) (y:ys) = case compare x (fst y) of
    LT -> Nothing      : lookupAll xs (y:ys)
    EQ -> Just (snd y) : lookupAll xs (y:ys)
    GT -> lookupAll (x:xs) ys

-- | @chunksOfSize size strings@ splits a given list of strings into chunks not
-- exceeding the given @size@. If that is impossible, it uses singleton chunks.
chunksOfSize :: Int -> [String] -> [[String]]
chunksOfSize n = repeatedly f
  where
    f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs

-- | Add single quotes around a string.
quote :: String -> String
quote s = "'" ++ s ++ "'"

-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
yesNo :: Bool -> String
yesNo True  = "YES"
yesNo False = "NO"

-- | Parse a 'Bool' from a @"YES"@ or @"NO"@ string. Returns @Nothing@ in case
-- of a parse failure.
parseYesNo :: String -> Maybe Bool
parseYesNo "YES" = Just True
parseYesNo "NO"  = Just False
parseYesNo _     = Nothing

-- | Pretty-print a 'Bool' as a @"0"@ or @"1"@ string
zeroOne :: Bool -> String
zeroOne False = "0"
zeroOne True  = "1"

-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx

-- | Combine paths with a forward slash regardless of platform.
(-/-) :: FilePath -> FilePath -> FilePath
_  -/- b | isAbsolute b && not (isAbsolute $ tail b) = b
"" -/- b = b
a  -/- b
    | last a == '/' = a ++       b
    | otherwise     = a ++ '/' : b

infixr 6 -/-

-- | This is like Posix makeRelative, but assumes no sys links in the input
-- paths. This allows the result to start with possibly many "../"s. Input
-- paths must both be relative, or be on the same drive
makeRelativeNoSysLink :: FilePath -> FilePath  -> FilePath
makeRelativeNoSysLink a b
    | aDrive == bDrive
        = if aToB == []
            then "."
            else joinPath aToB
    | otherwise
        = error $ if isRelative a /= isRelative b
            then "Paths must both be relative or both be absolute, but got"
                    ++ " \"" ++ a      ++ "\" and \"" ++ b      ++ "\""
            else "Paths are on different drives "
                    ++ " \"" ++ aDrive ++ "\" and \"" ++ bDrive ++ "\""
    where
        (aDrive, aRelPath) = splitDrive a
        (bDrive, bRelPath) = splitDrive b

        aRelSplit = removeIndirections (splitPath aRelPath)
        bRelSplit = removeIndirections (splitPath bRelPath)

        -- Use removePrefix to get the relative paths relative to a new
        -- base directory as high in the directory tree as possible.
        (baseToA, baseToB) = removePrefix aRelSplit bRelSplit
        aToBase = if isDirUp (head baseToA)
                    -- if baseToA contains any '..' then there is no way to get
                    -- a path from a to the base directory.
                    -- E.g. if   baseToA == "../u/v"
                    --      then aToBase == "../../<UnknownDir>"
                    then error $ "Impossible to find relatieve path from "
                                    ++ a ++ " to " ++ b
                    else".." <$ baseToA
        aToB = aToBase ++ baseToB

        -- removePrefix "pre123" "prefix456" == ("123", "fix456")
        removePrefix :: Eq a => [a] -> [a] -> ([a], [a])
        removePrefix as [] = (as, [])
        removePrefix [] bs = ([], bs)
        removePrefix (a:as) (b:bs)
            | a == b    = removePrefix as bs
            | otherwise = (a:as, b:bs)

        -- Removes all '.', and tries to remove all '..'. In some cases '..'s
        -- cannot be removes, but will all appear to the left.
        -- e.g. removeIndirections "../a/./b/../../../c" == "../../c"
        removeIndirections :: [String] -> [String]
        removeIndirections [] = []
        removeIndirections (x:xs)
            -- Remove all '.'
            | isDot   x = removeIndirections xs
            -- Bubble all '..' to the left
            | otherwise = case removeIndirections xs of
                        []     -> [x]
                        -- Only when x /= '..' and y == '..' do we need to
                        -- bubble to the left. In that case they cancel out
                        (y:ys) -> if not (isDirUp x) && isDirUp y
                                    then ys
                                    else x : y : ys

        isDirUp ".." = True
        isDirUp "../" = True
        isDirUp _ = False

        isDot "." = True
        isDot "./" = True
        isDot _ = False

-- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
-- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
-- can be matched by the same file, such as @library_p.a@. We break the tie
-- by preferring longer matches, which correpond to longer patterns.
(%%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
p %%> a = priority (fromIntegral (length p) + 1) $ p %> a

infix 1 %%>

-- | Build command lines can get very long; for example, when building the Cabal
-- library, they can reach 2MB! Some operating systems do not support command
-- lines of such length, and this function can be used to obtain a reasonable
-- approximation of the limit. On Windows, it is theoretically 32768 characters
-- (since Windows 7). In practice we use 31000 to leave some breathing space for
-- the builder path & name, auxiliary flags, and other overheads. On Mac OS X,
-- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over
-- 20000. Hence, 200000 seems like a sensible limit. On other operating systems
-- we currently use the 4194304 setting.
cmdLineLengthLimit :: Int
cmdLineLengthLimit | isWindows = 31000
                   | isMac     = 200000
                   | otherwise = 4194304

-- | Insert a value into Shake's type-indexed map.
insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
insertExtra value = Map.insert (typeOf value) (toDyn value)

-- | Lookup a value in Shake's type-indexed map.
lookupExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> a
lookupExtra defaultValue extra = fromMaybe defaultValue maybeValue
  where
    maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra

-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
-- setting is not found, return the provided default value instead.
userSetting :: Typeable a => a -> Action a
userSetting defaultValue = do
    extra <- shakeExtra <$> getShakeOptions
    return $ lookupExtra defaultValue extra

-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
-- setting is not found, return the provided default value instead.
userSettingRules :: Typeable a => a -> Rules a
userSettingRules defaultValue = do
    extra <- shakeExtra <$> getShakeOptionsRules
    return $ lookupExtra defaultValue extra

newtype BuildRoot = BuildRoot FilePath deriving (Typeable, Eq, Show)

-- | All build results are put into the 'buildRoot' directory.
buildRoot :: Action FilePath
buildRoot = do
    BuildRoot path <- userSetting (BuildRoot "")
    return path

buildRootRules :: Rules FilePath
buildRootRules = do
    BuildRoot path <- userSettingRules (BuildRoot "")
    return path

-- | A version of 'fmap' with flipped arguments. Useful for manipulating values
-- in context, e.g. 'buildRoot', as in the example below.
--
-- @
-- buildRoot <&> (-/- "dir") == fmap (-/- "dir") buildRoot
-- @
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap

infixl 1 <&>

-- | Given a 'FilePath' to a source file, return 'True' if it is generated.
-- The current implementation simply assumes that a file is generated if it
-- lives in the 'buildRoot' directory. Since most files are not generated the
-- test is usually very fast.
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)

-- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
    need [source] -- Guarantee the source is built before printing progress info.
    let dir = takeDirectory target
    liftIO $ IO.createDirectoryIfMissing True dir
    putProgressInfo =<< renderAction "Copy file" source target
    quietly $ copyFileChanged source target

-- | Copy a file without tracking the source. Create the target directory if missing.
copyFileUntracked :: FilePath -> FilePath -> Action ()
copyFileUntracked source target = do
    let dir = takeDirectory target
    liftIO $ IO.createDirectoryIfMissing True dir
    putProgressInfo =<< renderAction "Copy file (untracked)" source target
    liftIO $ IO.copyFile source target

-- | Transform a given file by applying a function to its contents.
fixFile :: FilePath -> (String -> String) -> Action ()
fixFile file f = do
    putProgressInfo $ "| Fix " ++ file
    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
        old <- IO.hGetContents h
        let new = f old
        IO.evaluate $ rnf new
        return new
    liftIO $ writeFile file contents

-- | Make a given file executable by running the @chmod +x@ command.
makeExecutable :: FilePath -> Action ()
makeExecutable file = do
    putProgressInfo $ "| Make " ++ quote file ++ " executable."
    quietly $ cmd "chmod +x " [file]

-- | Move a file. Note that we cannot track the source, because it is moved.
moveFile :: FilePath -> FilePath -> Action ()
moveFile source target = do
    putProgressInfo =<< renderAction "Move file" source target
    quietly $ cmd ["mv", source, target]

-- | Remove a file that doesn't necessarily exist.
removeFile :: FilePath -> Action ()
removeFile file = do
    putProgressInfo $ "| Remove file " ++ file
    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file

-- | Create a directory if it does not already exist.
createDirectory :: FilePath -> Action ()
createDirectory dir = do
    putProgressInfo $ "| Create directory " ++ dir
    liftIO $ IO.createDirectoryIfMissing True dir

-- | Copy a directory. The contents of the source directory is untracked.
copyDirectory :: FilePath -> FilePath -> Action ()
copyDirectory source target = do
    putProgressInfo =<< renderAction "Copy directory" source target
    quietly $ cmd ["cp", "-r", source, target]

-- | Move a directory. The contents of the source directory is untracked.
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
    putProgressInfo =<< renderAction "Move directory" source target
    quietly $ cmd ["mv", source, target]

-- | Remove a directory that doesn't necessarily exist.
removeDirectory :: FilePath -> Action ()
removeDirectory dir = do
    putProgressInfo $ "| Remove directory " ++ dir
    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir

data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)

-- | Terminal output colours
data Colour
    = Dull ANSIColour   -- ^ 8-bit ANSI colours
    | Vivid ANSIColour  -- ^ 16-bit vivid ANSI colours
    | Extended String   -- ^ Extended 256-bit colours, manual code stored

-- | ANSI terminal colours
data ANSIColour
    = Black     -- ^ ANSI code: 30
    | Red       -- ^ 31
    | Green     -- ^ 32
    | Yellow    -- ^ 33
    | Blue      -- ^ 34
    | Magenta   -- ^ 35
    | Cyan      -- ^ 36
    | White     -- ^ 37
    | Reset     -- ^ 0

-- | Convert ANSI colour names into their associated codes
colourCode :: ANSIColour -> String
colourCode Black = "30"
colourCode Red = "31"
colourCode Green = "32"
colourCode Yellow = "33"
colourCode Blue = "34"
colourCode Magenta = "35"
colourCode Cyan = "36"
colourCode White = "37"
colourCode Reset = "0"

-- | Create the final ANSI code.
mkColour :: Colour -> String
mkColour (Dull c) = colourCode c
mkColour (Vivid c) = colourCode c ++ ";1"
mkColour (Extended code) = "38;5;" ++ code

-- | A more colourful version of Shake's 'putNormal'.
putColoured :: String -> String -> Action ()
putColoured code msg = do
    useColour <- userSetting Never
    supported <- liftIO $ (&&) <$> IO.hIsTerminalDevice IO.stdout
                               <*> (not <$> isDumb)
    let c Never  = False
        c Auto   = supported || IO.isWindows -- Colours do work on Windows
        c Always = True
    if c useColour
        then putNormal $ "\ESC[" ++ code ++ "m" ++ msg ++ "\ESC[0m"
        else putNormal msg
  where
    isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"

newtype BuildProgressColour = BuildProgressColour String
    deriving Typeable

-- | Generate an encoded colour for progress output from names.
mkBuildProgressColour :: Colour -> BuildProgressColour
mkBuildProgressColour c = BuildProgressColour $ mkColour c

-- | Default 'BuildProgressColour'.
magenta :: BuildProgressColour
magenta = mkBuildProgressColour (Dull Magenta)

-- | Print a build progress message (e.g. executing a build command).
putBuild :: String -> Action ()
putBuild msg = do
    BuildProgressColour code <- userSetting magenta
    putColoured code msg

newtype SuccessColour = SuccessColour String
    deriving Typeable

-- | Generate an encoded colour for successful output from names
mkSuccessColour :: Colour -> SuccessColour
mkSuccessColour c = SuccessColour $ mkColour c

-- | Default 'SuccessColour'.
green :: SuccessColour
green = mkSuccessColour (Dull Green)

-- | Print a success message (e.g. a package is built successfully).
putSuccess :: String -> Action ()
putSuccess msg = do
    SuccessColour code <- userSetting green
    putColoured code msg

data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)

-- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
putProgressInfo :: String -> Action ()
putProgressInfo msg = do
    progressInfo <- userSetting None
    when (progressInfo /= None) $ putBuild msg

-- | Render an action.
renderAction :: String -> FilePath -> FilePath -> Action String
renderAction what input output = do
    progressInfo <- userSetting Brief
    return $ case progressInfo of
        None    -> ""
        Brief   -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
        Normal  -> renderBox [ what, "     input: " ++ i, " => output: " ++ o ]
        Unicorn -> renderUnicorn [ what, "     input: " ++ i, " => output: " ++ o ]
  where
    i = unifyPath input
    o = unifyPath output

-- | Render an action.
renderActionNoOutput :: String -> FilePath -> Action String
renderActionNoOutput what input = do
    progressInfo <- userSetting Brief
    return $ case progressInfo of
        None    -> ""
        Brief   -> "| " ++ what ++ ": " ++ i
        Normal  -> renderBox [ what, "     input: " ++ i ]
        Unicorn -> renderUnicorn [ what, "     input: " ++ i ]
  where
    i = unifyPath input

-- | Render the successful build of a program.
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox $
    [ "Successfully built program " ++ name
    , "Executable: " ++ bin ] ++
    [ "Program synopsis: " ++ endWithADot synopsis | not (null synopsis) ]

-- | Render the successful build of a library.
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox $
    [ "Successfully built library " ++ name
    , "Library: " ++ lib ] ++
    [ "Library synopsis: " ++ endWithADot synopsis | not (null synopsis) ]

endWithADot :: String -> String
endWithADot s = dropWhileEnd isPunctuation s ++ "."

-- | Render the given set of lines in an ASCII box. The minimum width and
-- whether to use Unicode symbols are hardcoded in the function's body.
--
-- >>> renderBox (words "lorem ipsum")
-- /----------\
-- | lorem    |
-- | ipsum    |
-- \----------/
renderBox :: [String] -> String
renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
  where
    -- Minimum total width of the box in characters
    minimumBoxWidth = 32

    -- TODO: Make this setting configurable? Setting to True by default seems
    -- to work poorly with many fonts.
    useUnicode = False

    -- Characters to draw the box
    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
        | useUnicode = ('â”€', 'â”‚', 'â•',  'â•®', 'â•°', 'â•¯', ' ')
        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')

    -- Box width, taking minimum desired length and content into account.
    -- The -4 is for the beginning and end pipe/padding symbols, as
    -- in "| xxx |".
    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
      where
        maxContentLength = maximum (map length ls)

    renderLine l = concat
        [ [pipe, padding]
        , padToLengthWith boxContentWidth padding l
        , [padding, pipe] ]
      where
        padToLengthWith n filler x = x ++ replicate (n - length x) filler

    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
                       , botLeft : dashes ++ [botRight] )
      where
        -- +1 for each non-dash (= corner) char
        dashes = replicate (boxContentWidth + 2) dash

-- | Render the given set of lines next to our favorite unicorn Robert.
renderUnicorn :: [String] -> String
renderUnicorn ls =
    unlines $ take (max (length ponyLines) (length boxLines)) $
        zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
  where
    ponyLines :: [String]
    ponyLines = [ "                   ,;,,;'"
                , "                  ,;;'(    Robert the spitting unicorn"
                , "       __       ,;;' ' \\   wants you to know"
                , "     /'  '\\'~~'~' \\ /'\\.)  that a task      "
                , "  ,;(      )    /  |.  /   just finished!   "
                , " ,;' \\    /-.,,(   ) \\                      "
                , " ^    ) /       ) / )|     Almost there!    "
                , "      ||        ||  \\)                      "
                , "      (_\\       (_\\                         " ]
    ponyPadding :: String
    ponyPadding = "                                            "
    boxLines :: [String]
    boxLines = ["", "", ""] ++ (lines . renderBox $ ls)


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Builder.Ar
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Support for invoking the archiving utility @ar@. We take care not to exceed
-- the limit on command line length, which differs across supported operating
-- systems (see 'cmdLineLengthLimit'). We need to handle @ar@ in a special way
-- because we sometimes archive __a lot__ of files (in the Cabal library, for
-- example, command line length can reach 2MB!). To work around the limit on the
-- command line length we pass the list of files to be archived via a temporary
-- file (see 'runAr'), or alternatively, we split the argument list into chunks
-- and call @ar@ multiple times, e.g. when passing arguments via a temporary
-- file is not supported (see 'runArWithoutTempFile').
-----------------------------------------------------------------------------
module Hadrian.Builder.Ar (ArMode (..), args, runAr, runArWithoutTempFile) where

import Control.Monad
import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Hadrian.Utilities

-- | We support packing and unpacking archives with @ar@.
data ArMode = Pack | Unpack deriving (Eq, Generic, Show)

instance Binary   ArMode
instance Hashable ArMode
instance NFData   ArMode

-- NOTE: Make sure to appropriately update 'arFlagsCount' when changing 'args'.
-- | Default command line arguments for invoking the archiving utility @ar@.
args :: (ShakeValue c, ShakeValue b) => ArMode -> Args c b
args Pack   = mconcat [ arg "q", arg =<< getOutput, getInputs ]
args Unpack = mconcat [ arg "x", arg =<< getInput ]

-- This count includes "q" and the output file argumentes in 'args'. This is
-- only relevant for the 'Pack' @ar@ mode.
arFlagsCount :: Int
arFlagsCount = 2

-- | Invoke @ar@ given a path to it and a list of arguments. The list of files
-- to be archived is passed via a temporary file. Passing arguments via a
-- temporary file is not supported by some versions of @ar@, in which case you
-- should use 'runArWithoutTempFile' instead.
runAr :: FilePath -> [String] -> Action ()
runAr arPath argList = withTempFile $ \tmp -> do
    writeFile' tmp $ unwords fileArgs
    cmd [arPath] flagArgs ('@' : tmp)
  where
    flagArgs = take arFlagsCount argList
    fileArgs = drop arFlagsCount argList

-- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@
-- will be called multiple times if the list of files to be archived is too
-- long and doesn't fit into the command line length limit. This function is
-- typically much slower than 'runAr'.
runArWithoutTempFile :: FilePath -> [String] -> Action ()
runArWithoutTempFile arPath argList =
    forM_ (chunksOfSize cmdLineLengthLimit fileArgs) $ \argsChunk ->
        unit . cmd [arPath] $ flagArgs ++ argsChunk
  where
    flagArgs = take arFlagsCount argList
    fileArgs = drop arFlagsCount argList


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Builder.Sphinx
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Support for invoking the documentation utility Sphinx.
-----------------------------------------------------------------------------
module Hadrian.Builder.Sphinx (SphinxMode (..), args) where

import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Hadrian.Utilities

-- | Sphinx can be used in three different modes to convert reStructuredText
-- documents into HTML, LaTeX or Man pages.
data SphinxMode = Html | Latex | Man deriving (Eq, Generic, Show)

instance Binary   SphinxMode
instance Hashable SphinxMode
instance NFData   SphinxMode

-- | Default command line arguments for invoking the archiving utility @tar@.
args :: (ShakeValue c, ShakeValue b) => SphinxMode -> Args c b
args mode = do
    outPath <- getOutput
    mconcat [ arg "-b", arg modeString
            , arg "-d", arg $ outPath -/- (".doctrees-" ++ modeString)
            , arg =<< getInput
            , arg outPath ]
  where
    modeString = case mode of
        Html  -> "html"
        Latex -> "latex"
        Man   -> "man"


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Builder.Tar
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Support for invoking the archiving utility @tar@.
-----------------------------------------------------------------------------
module Hadrian.Builder.Tar (TarMode (..), args) where

import Development.Shake
import Development.Shake.Classes
import GHC.Generics
import Hadrian.Expression
import Oracles.Setting

-- | Tar can be used to 'Create' an archive or 'Extract' from it.
data TarMode = Create | Extract deriving (Eq, Generic, Show)

instance Binary   TarMode
instance Hashable TarMode
instance NFData   TarMode

-- | Default command line arguments for invoking the archiving utility @tar@.
args :: (ShakeValue c, ShakeValue b) => TarMode -> Args c b
args Create = mconcat
    [ arg "-c"
    , output "//*.gz"  ? arg "--gzip"
    , output "//*.bz2" ? arg "--bzip2"
    , output "//*.xz"  ? arg "--xz"
    , arg "-f", arg =<< getOutput
    , getInputs ]
args Extract = mconcat
    [ arg "-x"
    , windowsHost ? arg "--force-local"
    , input "*.gz"  ? arg "--gzip"
    , input "*.bz2" ? arg "--bzip2"
    , input "*.xz"  ? arg "--xz"
    , arg "-f", arg =<< getInput
    , arg "-C", arg =<< getOutput ]


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Haskell.Cabal
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Basic functionality for extracting Haskell package metadata stored in
-- Cabal files.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal (
    pkgVersion, pkgIdentifier, pkgSynopsis, pkgDescription, pkgDependencies,
    pkgGenericDescription, cabalArchString, cabalOsString,
    ) where

import Development.Shake
import Distribution.PackageDescription (GenericPackageDescription)

import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal
import Hadrian.Package

-- | Read a Cabal file and return the package version. The Cabal file is tracked.
pkgVersion :: Package -> Action String
pkgVersion = fmap version . readPackageData

-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@.
-- The Cabal file is tracked.
pkgIdentifier :: Package -> Action String
pkgIdentifier package = do
    cabal <- readPackageData package
    return $ if null (version cabal)
        then name cabal
        else name cabal ++ "-" ++ version cabal

-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
pkgSynopsis :: Package -> Action String
pkgSynopsis = fmap synopsis . readPackageData

-- | Read a Cabal file and return the package description. The Cabal file is
-- tracked.
pkgDescription :: Package -> Action String
pkgDescription = fmap description . readPackageData

-- | Read a Cabal file and return the sorted list of the package dependencies.
-- The current version does not take care of Cabal conditionals and therefore
-- returns a crude overapproximation of actual dependencies. The Cabal file is
-- tracked.
pkgDependencies :: Package -> Action [PackageName]
pkgDependencies = fmap (map pkgName . packageDependencies) . readPackageData

-- | Read a Cabal file and return the 'GenericPackageDescription'. The Cabal
-- file is tracked.
pkgGenericDescription :: Package -> Action GenericPackageDescription
pkgGenericDescription = fmap genericPackageDescription . readPackageData

-- | Cabal's rendering of an architecture as used in its directory structure.
--
-- Inverse of 'Cabal.Distribution.Simple.GHC.ghcArchString'.
cabalArchString :: String -> String
cabalArchString "powerpc"   = "ppc"
cabalArchString "powerpc64" = "ppc64"
cabalArchString other       = other

-- | Cabal's rendering of an OS as used in its directory structure.
--
-- Inverse of 'Cabal.Distribution.Simple.GHC.ghcOsString'.
cabalOsString :: String -> String
cabalOsString "mingw32"  = "windows"
cabalOsString "darwin"   = "osx"
cabalOsString "solaris2" = "solaris"
cabalOsString other      = other


{-# OPTIONS_GHC -Wno-deprecations #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Haskell.Cabal.Parse
-- Copyright  : (c) Andrey Mokhov 2014-2017
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Extracting Haskell package metadata stored in Cabal files.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal.Parse (
    parsePackageData, resolveContextData, parseCabalPkgId, configurePackage,
    buildAutogenFiles, copyPackage, registerPackage
    ) where

import Data.Bifunctor
import Data.List.Extra
import Development.Shake
import qualified Distribution.ModuleName                       as C
import qualified Distribution.Package                          as C
import qualified Distribution.PackageDescription               as C
import qualified Distribution.PackageDescription.Configuration as C
import qualified Distribution.PackageDescription.Parsec        as C
import qualified Distribution.Simple.Compiler                  as C
import qualified Distribution.Simple.Program.Db                as C
import qualified Distribution.Simple                           as C
import qualified Distribution.Simple.Program.Builtin           as C
import qualified Distribution.Simple.Utils                     as C
import qualified Distribution.Simple.Program.Types             as C
import qualified Distribution.Simple.Configure                 as C (getPersistBuildConfig)
import qualified Distribution.Simple.Build                     as C
import qualified Distribution.Types.ComponentRequestedSpec     as C
import qualified Distribution.InstalledPackageInfo             as Installed
import qualified Distribution.Simple.PackageIndex              as C
import qualified Distribution.Text                             as C
import qualified Distribution.Types.LocalBuildInfo             as C
import qualified Distribution.Types.CondTree                   as C
import qualified Distribution.Types.MungedPackageId            as C
import qualified Distribution.Verbosity                        as C
import Hadrian.Expression
import Hadrian.Haskell.Cabal
import Hadrian.Haskell.Cabal.Type
import Hadrian.Oracles.Cabal
import Hadrian.Target

import Base
import Builder
import Context
import Flavour
import Packages
import Settings

-- | Parse the Cabal file of a given 'Package'. This operation is cached by the
-- "Hadrian.Oracles.TextFile.readPackageData" oracle.
parsePackageData :: Package -> Action PackageData
parsePackageData pkg = do
    gpd <- liftIO $ C.readGenericPackageDescription C.verbose (pkgCabalFile pkg)
    let pd      = C.packageDescription gpd
        pkgId   = C.package pd
        name    = C.unPackageName (C.pkgName pkgId)
        version = C.display (C.pkgVersion pkgId)
        libDeps = collectDeps (C.condLibrary gpd)
        exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd)
        allDeps = concat (libDeps : exeDeps)
        sorted  = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
        deps    = nubOrd sorted \\ [name]
        depPkgs = catMaybes $ map findPackageByName deps
    return $ PackageData name version (C.synopsis pd) (C.description pd) depPkgs gpd
  where
    -- Collect an overapproximation of dependencies by ignoring conditionals
    collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
    collectDeps Nothing = []
    collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs
      where
        f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt

-- | Parse the package identifier from a Cabal file.
parseCabalPkgId :: FilePath -> IO String
parseCabalPkgId file = C.display . C.package . C.packageDescription <$> C.readGenericPackageDescription C.silent file

biModules :: C.PackageDescription -> (C.BuildInfo, [C.ModuleName], Maybe (C.ModuleName, String))
biModules pd = go [ comp | comp@(bi,_,_) <-
                             (map libBiModules . maybeToList $ C.library pd) ++
                             (map exeBiModules               $ C.executables pd)
                         , C.buildable bi ]
  where
    libBiModules lib = (C.libBuildInfo lib, C.explicitLibModules lib, Nothing)
    exeBiModules exe = (C.buildInfo exe,
                       -- If "main-is: ..." is not a .hs or .lhs file, do not
                       -- inject "Main" into the modules.  This does not respect
                       -- "-main-is" ghc-arguments! See Cabal's
                       -- Distribution.Simple.GHC for the glory details.
                       if takeExtension (C.modulePath exe) `elem` [".hs", ".lhs"]
                           then C.main : C.exeModules exe
                                -- The module `Main` still need to be kept in `modules` of PD.
                           else C.exeModules exe,
                       Just (C.main, C.modulePath exe))
    go []  = error "No buildable component found."
    go [x] = x
    go _   = error "Cannot handle more than one buildinfo yet."

-- TODO: Track command line arguments and package configuration flags.
-- | Configure a package using the Cabal library by collecting all the command
-- line arguments (to be passed to the setup script) and package configuration
-- flags. The function 'need's package database entries for the dependencies of
-- the package the 'Context' points to.
configurePackage :: Context -> Action ()
configurePackage context@Context {..} = do
    putProgressInfo $ "| Configure package " ++ quote (pkgName package)
    gpd     <- pkgGenericDescription package
    depPkgs <- packageDependencies <$> readPackageData package

    -- Stage packages are those we have in this stage.
    stagePkgs <- stagePackages stage
    -- We'll need those packages in our package database.
    deps <- sequence [ pkgConfFile (context { package = pkg })
                     | pkg <- depPkgs, pkg `elem` stagePkgs ]
    need deps

    -- Figure out what hooks we need.
    hooks <- case C.buildType (C.flattenPackageDescription gpd) of
        C.Configure -> pure C.autoconfUserHooks
        -- The 'time' package has a 'C.Custom' Setup.hs, but it's actually
        -- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also
        -- 'C.Custom', but doesn't have a configure script.
        C.Custom -> do
            configureExists <- doesFileExist $
                replaceFileName (pkgCabalFile package) "configure"
            pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
        -- Not quite right, but good enough for us:
        _ | package == rts ->
            -- Don't try to do post configuration validation for 'rts'. This
            -- will simply not work, due to the @ld-options@ and @Stg.h@.
            pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
          | otherwise -> pure C.simpleUserHooks

    -- Compute the list of flags, and the Cabal configurartion arguments
    flavourArgs <- args <$> flavour
    flagList    <- interpret (target context (Cabal Flags stage) [] []) flavourArgs
    argList     <- interpret (target context (Cabal Setup stage) [] []) flavourArgs
    verbosity   <- getVerbosity
    let v = if verbosity >= Loud then "-v3" else "-v0"
    liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
        (argList ++ ["--flags=" ++ unwords flagList, v])

    dir <- Context.buildPath context
    files <- liftIO $ getDirectoryFilesIO "." [ dir -/- "include" <//> "*"
                                              , dir -/- "*.buildinfo"
                                              , dir -/- "lib" <//> "*"
                                              , dir -/- "config.*" ]
    produces files

-- | Copy the 'Package' of a given 'Context' into the package database
-- corresponding to the 'Stage' of the 'Context'.
copyPackage :: Context -> Action ()
copyPackage context@Context {..} = do
    putProgressInfo $ "| Copy package " ++ quote (pkgName package)
    gpd <- pkgGenericDescription package
    ctxPath   <- Context.contextPath context
    pkgDbPath <- packageDbPath stage
    verbosity <- getVerbosity
    let v = if verbosity >= Loud then "-v3" else "-v0"
    liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
        [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]

-- | Register the 'Package' of a given 'Context' into the package database.
registerPackage :: Context -> Action ()
registerPackage context@Context {..} = do
    putProgressInfo $ "| Register package " ++ quote (pkgName package)
    ctxPath <- Context.contextPath context
    gpd <- pkgGenericDescription package
    verbosity <- getVerbosity
    let v = if verbosity >= Loud then "-v3" else "-v0"
    liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
        [ "register", "--builddir", ctxPath, v ]

-- | Parse the 'ContextData' of a given 'Context'.
resolveContextData :: Context -> Action ContextData
resolveContextData context@Context {..} = do
    -- TODO: This is conceptually wrong!
    -- We should use the gpd, the flagAssignment and compiler, hostPlatform, and
    -- other information from the lbi. And then compute the finalised PD (flags,
    -- satisfiable dependencies, platform, compiler info, deps, gpd).
    --
    -- let (Right (pd,_)) = C.finalizePackageDescription flags (const True) platform (compilerInfo compiler) [] gpd
    --
    -- However when using the new-build path's this might change.

    -- Read the package description from the Cabal file
    gpd <- genericPackageDescription <$> readPackageData package

    -- Configure the package with the GHC for this stage
    (compiler, platform) <- configurePackageGHC package stage

    flagList <- interpret (target context (Cabal Flags stage) [] []) =<< args <$> flavour
    let flags = foldr addFlag mempty flagList
          where
            addFlag :: String -> C.FlagAssignment -> C.FlagAssignment
            addFlag ('-':name) = C.insertFlagAssignment (C.mkFlagName name) False
            addFlag ('+':name) = C.insertFlagAssignment (C.mkFlagName name) True
            addFlag name       = C.insertFlagAssignment (C.mkFlagName name) True

    let (Right (pd,_)) = C.finalizePD flags C.defaultComponentRequestedSpec
                         (const True) platform (C.compilerInfo compiler) [] gpd

    cPath <- Context.contextPath context
    lbi <- liftIO $ C.getPersistBuildConfig cPath

    -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
    -- from the local build info @lbi@.
    pdi <- liftIO $ getHookedBuildInfo [pkgPath package, cPath -/- "build"]
    let pd'  = C.updatePackageDescription pdi pd
        lbi' = lbi { C.localPkgDescr = pd' }

    -- TODO: Get rid of deprecated 'externalPackageDeps' and drop -Wno-deprecations
    -- See: https://github.com/snowleopard/hadrian/issues/548
    let extDeps      = C.externalPackageDeps lbi'
        deps         = map (C.display . snd) extDeps
        depDirect    = map (fromMaybe (error "resolveContextData: depDirect failed")
                     . C.lookupUnitId (C.installedPkgs lbi') . fst) extDeps
        depIds       = map (C.display . Installed.installedUnitId) depDirect
        Just ghcProg = C.lookupProgram C.ghcProgram (C.withPrograms lbi')
        depPkgs      = C.topologicalOrder (packageHacks (C.installedPkgs lbi'))
        forDeps f    = concatMap f depPkgs

        -- Copied from Distribution.Simple.PreProcess.ppHsc2Hs
        packageHacks = case C.compilerFlavor (C.compiler lbi') of
            C.GHC | C.pkgName (C.package pd') /= (C.mkPackageName "rts") -> hackRtsPackage
            _   -> id

        -- TODO: Get rid of this hack.
        -- We don't link in the actual Haskell libraries of our dependencies, so
        -- the "-u" flags in @ldOptions@ of the @rts@ package mean linking fails
        -- on OS X (its @ld@ is a tad stricter than GNU @ld@). Thus we remove
        -- @ldOptions@ for the @rts@ package. With one exception (see below).
        hackRtsPackage index | null (C.allPackages index) = index
        -- ^ do not hack the empty index
        hackRtsPackage index = case C.lookupPackageName index (C.mkPackageName "rts") of
            [(_, [rts])] -> C.insert rts {
                Installed.ldOptions   = [],
                Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`))
                                               (Installed.libraryDirs rts)} index
            -- GHC <= 6.12 had @$topdir/gcc-lib@ in their @library-dirs@ for the
            -- 'rts' package, which causes problems when we try to use the
            -- in-tree @mingw@, due to accidentally picking up the incompatible
            -- libraries there. So we filter out @gcc-lib@ from the RTS's
            -- @library-dirs@ here.
            _ -> error "No (or multiple) GHC rts package is registered!"

        (buildInfo, modules, mainIs) = biModules pd'

      in return $ ContextData
          { dependencies    = deps
          , componentId     = C.localCompatPackageKey lbi'
          , mainIs          = fmap (first C.display) mainIs
          , modules         = map C.display modules
          , otherModules    = map C.display $ C.otherModules buildInfo
          , srcDirs         = C.hsSourceDirs buildInfo
          , depIds          = depIds
          , depNames        = map (C.display . C.mungedName . snd) extDeps
          , includeDirs     = C.includeDirs     buildInfo
          , includes        = C.includes        buildInfo
          , installIncludes = C.installIncludes buildInfo
          , extraLibs       = C.extraLibs       buildInfo
          , extraLibDirs    = C.extraLibDirs    buildInfo
          , asmSrcs         = C.asmSources      buildInfo
          , cSrcs           = C.cSources        buildInfo
          , cmmSrcs         = C.cmmSources      buildInfo
          , hcOpts          = C.programDefaultArgs ghcProg
              ++ C.hcOptions C.GHC buildInfo
              ++ C.languageToFlags   (C.compiler lbi') (C.defaultLanguage buildInfo)
              ++ C.extensionsToFlags (C.compiler lbi') (C.usedExtensions  buildInfo)
              ++ C.programOverrideArgs ghcProg
          , asmOpts            = C.asmOptions buildInfo
          , ccOpts             = C.ccOptions  buildInfo
          , cmmOpts            = C.cmmOptions buildInfo
          , cppOpts            = C.cppOptions buildInfo
          , ldOpts             = C.ldOptions  buildInfo
          , depIncludeDirs     = forDeps Installed.includeDirs
          , depCcOpts          = forDeps Installed.ccOptions
          , depLdOpts          = forDeps Installed.ldOptions
          , buildGhciLib       = C.withGHCiLib lbi'
          , frameworks         = C.frameworks buildInfo
          , packageDescription = pd' }

-- | Build autogenerated files @autogen/cabal_macros.h@ and @autogen/Paths_*.hs@.
buildAutogenFiles :: Context -> Action ()
buildAutogenFiles context = do
    cPath <- Context.contextPath context
    setupConfig <- pkgSetupConfigFile context
    need [setupConfig] -- This triggers 'configurePackage'
    pd <- packageDescription <$> readContextData context
    -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
    -- from the local build info @lbi@.
    liftIO $ do
        lbi <- C.getPersistBuildConfig cPath
        C.initialBuildSteps cPath pd (lbi { C.localPkgDescr = pd }) C.silent

-- | Look for a @.buildinfo@ in all of the specified directories, stopping on
-- the first one we find.
getHookedBuildInfo :: [FilePath] -> IO C.HookedBuildInfo
getHookedBuildInfo [] = return C.emptyHookedBuildInfo
getHookedBuildInfo (baseDir:baseDirs) = do
    maybeInfoFile <- C.findHookedPackageDesc baseDir
    case maybeInfoFile of
        Nothing       -> getHookedBuildInfo baseDirs
        Just infoFile -> C.readHookedBuildInfo C.silent infoFile


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Haskell.Cabal.Type
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- Data types for storing basic Haskell package metadata, such as package name,
-- version and dependencies, extracted from a Cabal file.
-----------------------------------------------------------------------------
module Hadrian.Haskell.Cabal.Type where

import Development.Shake.Classes
import Distribution.PackageDescription
import GHC.Generics

import Hadrian.Package

-- | Haskell package metadata extracted from a Cabal file without performing
-- the resolution of package configuration flags and associated conditionals,
-- which are build context specific. Note that 'packageDependencies' is an
-- overappoximation of actual package dependencies; for example, both @unix@ and
-- @win32@ packages may be included even if only one of them is required on the
-- target OS. See 'ContextData' for metadata obtained after resolving package
-- configuration flags and conditionals according to the current build context.
data PackageData = PackageData
    { name                      :: PackageName
    , version                   :: String
    , synopsis                  :: String
    , description               :: String
    , packageDependencies       :: [Package]
    , genericPackageDescription :: GenericPackageDescription
    } deriving (Eq, Generic, Show, Typeable)

-- | Haskell package metadata obtained after resolving package configuration
-- flags and associated conditionals according to the current build context.
-- See 'PackageData' for metadata that can be obtained without resolving package
-- configuration flags and conditionals.
data ContextData = ContextData
    { dependencies       :: [PackageName]
    , componentId        :: String
    , mainIs             :: Maybe (String, FilePath)  -- ("Main", filepath)
    , modules            :: [String]
    , otherModules       :: [String]
    , srcDirs            :: [String]
    , depIds             :: [String]
    , depNames           :: [String]
    , includeDirs        :: [String]
    , includes           :: [String]
    , installIncludes    :: [String]
    , extraLibs          :: [String]
    , extraLibDirs       :: [String]
    , asmSrcs            :: [String]
    , cSrcs              :: [String]
    , cmmSrcs            :: [String]
    , hcOpts             :: [String]
    , asmOpts            :: [String]
    , ccOpts             :: [String]
    , cmmOpts            :: [String]
    , cppOpts            :: [String]
    , ldOpts             :: [String]
    , depIncludeDirs     :: [String]
    , depCcOpts          :: [String]
    , depLdOpts          :: [String]
    , buildGhciLib       :: Bool
    , frameworks         :: [String]
    , packageDescription :: PackageDescription
    } deriving (Eq, Generic, Show, Typeable)

instance Binary   PackageData
instance Hashable PackageData where hashWithSalt salt = hashWithSalt salt . show
instance NFData   PackageData

instance Binary   ContextData
instance Hashable ContextData where hashWithSalt salt = hashWithSalt salt . show
instance NFData   ContextData


{-# LANGUAGE TypeFamilies #-}
module Hadrian.Oracles.ArgsHash (
    TrackArgument, trackAllArguments, trackArgsHash, argsHashOracle
    ) where

import Control.Monad
import Development.Shake
import Development.Shake.Classes

import Hadrian.Expression hiding (inputs, outputs)
import Hadrian.Target

-- | 'TrackArgument' is used to specify the arguments that should be tracked by
-- the @ArgsHash@ oracle. The safest option is to track all arguments, but some
-- arguments, such as @-jN@, do not change the build results, hence there is no
-- need to initiate unnecessary rebuild if they are added to or removed from a
-- command line. If all arguments should be tracked, use 'trackAllArguments'.
type TrackArgument c b = Target c b -> String -> Bool

-- | Returns 'True' for all targets and arguments, hence can be used a safe
-- default for 'argsHashOracle'.
trackAllArguments :: TrackArgument c b
trackAllArguments _ _ = True

-- | Given a 'Target' this 'Action' determines the corresponding argument list
-- and computes its hash. The resulting value is tracked in a Shake oracle,
-- hence initiating rebuilds when the hash changes (a hash change indicates
-- changes in the build command for the given target).
-- Note: for efficiency we replace the list of input files with its hash to
-- avoid storing long lists of source files passed to some builders (e.g. ar)
-- in the Shake database. This optimisation is normally harmless, because
-- argument list constructors are assumed not to examine target sources, but
-- only append them to argument lists where appropriate.
trackArgsHash :: (ShakeValue c, ShakeValue b) => Target c b -> Action ()
trackArgsHash t = do
    let hashedInputs  = [ show $ hash (inputs t) ]
        hashedTarget = target (context t) (builder t) hashedInputs (outputs t)
    void (askOracle $ ArgsHash hashedTarget :: Action Int)

newtype ArgsHash c b = ArgsHash (Target c b)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult (ArgsHash c b) = Int

-- | This oracle stores per-target argument list hashes in the Shake database,
-- allowing the user to track them between builds using 'trackArgsHash' queries.
argsHashOracle :: (ShakeValue c, ShakeValue b) => TrackArgument c b -> Args c b -> Rules ()
argsHashOracle trackArgument args = void $
    addOracle $ \(ArgsHash target) -> do
        argList <- interpret target args
        let trackedArgList = filter (trackArgument target) argList
        return $ hash trackedArgList


-----------------------------------------------------------------------------
-- |
-- Module     : Hadrian.Oracles.Cabal
-- Copyright  : (c) Andrey Mokhov 2014-2018
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- This module defines oracles for reading and parsing Cabal files, as well as
-- for configuring Haskell packages.
-----------------------------------------------------------------------------
module Hadrian.Oracles.Cabal (
    readPackageData, readContextData, configurePackageGHC
    ) where

import Development.Shake
import Distribution.Simple (Compiler)
import Distribution.System (Platform)

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

-- | Read and parse a Cabal file, caching and tracking the result.
readPackageData :: Package -> Action PackageData
readPackageData = askOracle . PackageDataKey

-- | Read and parse a Cabal file recording the obtained 'ContextData', caching
-- and tracking the result. Note that unlike 'readPackageData' this function
-- resolves all Cabal configuration flags and associated conditionals.
readContextData :: Context -> Action ContextData
readContextData = askOracle . ContextDataKey

-- | Configure a 'Package' using the GHC corresponding to a given 'Stage',
-- caching and tracking the result.
configurePackageGHC :: Package -> Stage -> Action (Compiler, Platform)
configurePackageGHC pkg stage = do
    PackageConfiguration res <- askOracle $ PackageConfigurationKey (pkg, stage)
    return res


{-# LANGUAGE TypeFamilies #-}
module Hadrian.Oracles.DirectoryContents (
    directoryContents, copyDirectoryContents, directoryContentsOracle, copyDirectoryContentsUntracked,
    Match (..), matches, matchAll
    ) where

import Control.Monad
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import GHC.Generics

import Hadrian.Utilities

import qualified System.Directory.Extra as IO

data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
    deriving (Generic, Eq, Show, Typeable)

instance Binary   Match
instance Hashable Match
instance NFData   Match

-- | A 'Match' expression that always evaluates to 'True' (i.e. always matches).
matchAll :: Match
matchAll = And []

-- | Check if a file name matches a given 'Match' expression.
matches :: Match -> FilePath -> Bool
matches (Test p) f = p ?== f
matches (Not  m) f = not $ matches m f
matches (And ms) f = all (`matches` f) ms
matches (Or  ms) f = any (`matches` f) ms

-- | Given a 'Match' expression and a directory, recursively traverse it and all
-- its subdirectories to find and return all matching contents.
directoryContents :: Match -> FilePath -> Action [FilePath]
directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)

-- | Copy the contents of the source directory that matches a given 'Match'
-- expression into the target directory. The copied contents is tracked.
copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
copyDirectoryContents expr source target = do
    putProgressInfo =<< renderAction "Copy directory contents" source target
    let cp file = copyFile file $ target -/- makeRelative source file
    mapM_ cp =<< directoryContents expr source

-- | Copy the contents of the source directory that matches a given 'Match'
-- expression into the target directory. The copied contents is untracked.
copyDirectoryContentsUntracked :: Match -> FilePath -> FilePath -> Action ()
copyDirectoryContentsUntracked expr source target = do
    putProgressInfo =<< renderAction "Copy directory contents (untracked)" source target
    let cp file = copyFileUntracked file $ target -/- makeRelative source file
    mapM_ cp =<< directoryContents expr source

newtype DirectoryContents = DirectoryContents (Match, FilePath)
    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
type instance RuleResult DirectoryContents = [FilePath]

-- | This oracle answers 'directoryContents' queries and tracks the results.
directoryContentsOracle :: Rules ()
directoryContentsOracle = void $
    addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
        filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir