Merge commit '7b0b9f603bb1215e2b7af23c2404d637b95a4988' as 'hadrian'

14 files changed, 1387 insertions, 0 deletions

diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs
new file mode 100644
index 0000000000..4de658edc3
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder.hs
@@ -0,0 +1,125 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 (..), runBuilder, runBuilderWithCmdOptions,
+    build, buildWithResources, buildWithCmdOptions, getBuilderPath,
+    builderEnvironment
+    ) 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
+
+    -- | Make sure a builder exists and rebuild it if out of date.
+    needBuilder :: b -> Action ()
+    needBuilder builder = do
+        path <- builderPath builder
+        need [path]
+
+    -- | 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
+
+-- | 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 []
+
+-- | 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 []
+
+buildWith :: (Builder b, ShakeValue c) => [(Resource, Int)] -> [CmdOption] -> Target c b -> Args c b -> Action ()
+buildWith rs opts target args = do
+    needBuilder (builder target)
+    argList <- interpret target args
+    trackArgsHash target -- Rerun the rule if the hash of argList has changed.
+    putInfo target
+    verbose <- interpret target verboseCommand
+    let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
+    quietlyUnlessVerbose $ runBuilderWith (builder target) $
+        BuildInfo { buildArgs      = argList
+                  , buildInputs    = inputs target
+                  , buildOutputs   = outputs target
+                  , buildOptions   = opts
+                  , buildResources = rs }
+
+-- | Print out information about the command being executed.
+putInfo :: Show b => Target c b -> Action ()
+putInfo 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)"
+
+-- | 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
diff --git a/hadrian/src/Hadrian/Builder/Ar.hs b/hadrian/src/Hadrian/Builder/Ar.hs
new file mode 100644
index 0000000000..ad74653db0
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Ar.hs
@@ -0,0 +1,68 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
diff --git a/hadrian/src/Hadrian/Builder/Sphinx.hs b/hadrian/src/Hadrian/Builder/Sphinx.hs
new file mode 100644
index 0000000000..44b522c4d3
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Sphinx.hs
@@ -0,0 +1,39 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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"
diff --git a/hadrian/src/Hadrian/Builder/Tar.hs b/hadrian/src/Hadrian/Builder/Tar.hs
new file mode 100644
index 0000000000..d51e3c7bee
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Tar.hs
@@ -0,0 +1,40 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+
+-- | 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"
+    , input "*.gz"  ? arg "--gzip"
+    , input "*.bz2" ? arg "--bzip2"
+    , input "*.xz"  ? arg "--xz"
+    , arg "-f", arg =<< getInput
+    , arg "-C", arg =<< getOutput ]
diff --git a/hadrian/src/Hadrian/Expression.hs b/hadrian/src/Hadrian/Expression.hs
new file mode 100644
index 0000000000..e5c01f8935
--- /dev/null
+++ b/hadrian/src/Hadrian/Expression.hs
@@ -0,0 +1,153 @@
+{-# 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 Data.Semigroup
+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, Semigroup 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)
diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs
new file mode 100644
index 0000000000..ab5f334f9b
--- /dev/null
+++ b/hadrian/src/Hadrian/Haskell/Cabal.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Haskell.Cabal
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- 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, pkgDependencies, pkgSynopsis
+    ) where
+
+import Development.Shake
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Package
+import Hadrian.Oracles.TextFile
+
+-- | Read a Cabal file and return the package version. The Cabal file is tracked.
+pkgVersion :: FilePath -> Action String
+pkgVersion cabalFile = version <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package identifier, e.g. @base-4.10.0.0@.
+-- The Cabal file is tracked.
+pkgIdentifier :: FilePath -> Action String
+pkgIdentifier cabalFile = do
+    cabal <- readCabalFile cabalFile
+    return $ if null (version cabal)
+        then name cabal
+        else name cabal ++ "-" ++ version cabal
+
+-- | 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 :: FilePath -> Action [PackageName]
+pkgDependencies cabalFile = dependencies <$> readCabalFile cabalFile
+
+-- | Read a Cabal file and return the package synopsis. The Cabal file is tracked.
+pkgSynopsis :: FilePath -> Action String
+pkgSynopsis cabalFile = synopsis <$> readCabalFile cabalFile
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
new file mode 100644
index 0000000000..578eeacc52
--- /dev/null
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -0,0 +1,63 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 (Cabal (..), parseCabal) where
+
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import qualified Distribution.Package                  as C
+import qualified Distribution.PackageDescription       as C
+import qualified Distribution.PackageDescription.Parse as C
+import qualified Distribution.Text                     as C
+import qualified Distribution.Types.CondTree           as C
+import qualified Distribution.Verbosity                as C
+
+import Hadrian.Package
+
+-- TODO: Use fine-grain tracking instead of tracking the whole Cabal file.
+-- | Haskell package metadata extracted from a Cabal file.
+data Cabal = Cabal
+    { dependencies :: [PackageName]
+    , name         :: PackageName
+    , synopsis     :: String
+    , version      :: String
+    } deriving (Eq, Read, Show, Typeable)
+
+instance Binary Cabal where
+    put = put . show
+    get = fmap read get
+
+instance Hashable Cabal where
+    hashWithSalt salt = hashWithSalt salt . show
+
+instance NFData Cabal where
+    rnf (Cabal a b c d) = a `seq` b `seq` c `seq` d `seq` ()
+
+-- | Parse a Cabal file.
+parseCabal :: FilePath -> IO Cabal
+parseCabal file = do
+    gpd <- liftIO $ C.readGenericPackageDescription C.silent file
+    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]
+    return $ Cabal deps name (C.synopsis pd) version
+
+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
diff --git a/hadrian/src/Hadrian/Oracles/ArgsHash.hs b/hadrian/src/Hadrian/Oracles/ArgsHash.hs
new file mode 100644
index 0000000000..bae2fdbd80
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/ArgsHash.hs
@@ -0,0 +1,51 @@
+{-# 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
diff --git a/hadrian/src/Hadrian/Oracles/DirectoryContents.hs b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs
new file mode 100644
index 0000000000..f302af9da0
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/DirectoryContents.hs
@@ -0,0 +1,64 @@
+{-# 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
diff --git a/hadrian/src/Hadrian/Oracles/Path.hs b/hadrian/src/Hadrian/Oracles/Path.hs
new file mode 100644
index 0000000000..ceccc23db2
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/Path.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Oracles.Path (
+    lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
+    ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Char
+import Data.List.Extra
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Directory
+import System.Info.Extra
+
+import Hadrian.Utilities
+
+-- | Lookup a specified 'FilePath' in the system @PATH@.
+lookupInPath :: FilePath -> Action FilePath
+lookupInPath name
+    | name == takeFileName name = askOracle $ LookupInPath name
+    | otherwise                 = return name
+
+-- | Lookup the path to the @bash@ interpreter.
+bashPath :: Action FilePath
+bashPath = lookupInPath "bash"
+
+-- | Fix an absolute path on Windows:
+-- * "/c/" => "C:/"
+-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
+fixAbsolutePathOnWindows :: FilePath -> Action FilePath
+fixAbsolutePathOnWindows path =
+    if isWindows
+    then do
+        let (dir, file) = splitFileName path
+        winDir <- askOracle $ WindowsPath dir
+        return $ winDir -/- file
+    else
+        return path
+
+newtype LookupInPath = LookupInPath String
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult LookupInPath = String
+
+newtype WindowsPath = WindowsPath FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult WindowsPath = String
+
+-- | Oracles for looking up paths. These are slow and require caching.
+pathOracle :: Rules ()
+pathOracle = do
+    void $ addOracle $ \(WindowsPath path) -> do
+        Stdout out <- quietly $ cmd ["cygpath", "-m", path]
+        let windowsPath = unifyPath $ dropWhileEnd isSpace out
+        putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
+        return windowsPath
+
+    void $ addOracle $ \(LookupInPath name) -> do
+        let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
+        path <- unifyPath . unpack <$> liftIO (findExecutable name)
+        putLoud $ "| Executable found: " ++ name ++ " => " ++ path
+        return path
diff --git a/hadrian/src/Hadrian/Oracles/TextFile.hs b/hadrian/src/Hadrian/Oracles/TextFile.hs
new file mode 100644
index 0000000000..6d4f048c7d
--- /dev/null
+++ b/hadrian/src/Hadrian/Oracles/TextFile.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module     : Hadrian.Oracles.TextFile
+-- Copyright  : (c) Andrey Mokhov 2014-2017
+-- License    : MIT (see the file LICENSE)
+-- Maintainer : andrey.mokhov@gmail.com
+-- Stability  : experimental
+--
+-- Read and parse text files, tracking their contents. This oracle can be used
+-- to read configuration or package metadata files and cache the parsing.
+-----------------------------------------------------------------------------
+module Hadrian.Oracles.TextFile (
+    readTextFile, lookupValue, lookupValueOrEmpty, lookupValueOrError,
+    lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies,
+    readCabalFile, textFileOracle
+    ) where
+
+import Control.Monad
+import qualified Data.HashMap.Strict as Map
+import Data.Maybe
+import Development.Shake
+import Development.Shake.Classes
+import Development.Shake.Config
+
+import Hadrian.Haskell.Cabal.Parse
+import Hadrian.Utilities
+
+newtype TextFile = TextFile FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult TextFile = String
+
+newtype CabalFile = CabalFile FilePath
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult CabalFile = Cabal
+
+newtype KeyValue = KeyValue (FilePath, String)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValue = Maybe String
+
+newtype KeyValues = KeyValues (FilePath, String)
+    deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
+type instance RuleResult KeyValues = Maybe [String]
+
+-- | Read a text file, caching and tracking the result. To read and track
+-- individual lines of a text file use 'lookupValue' and its derivatives.
+readTextFile :: FilePath -> Action String
+readTextFile = askOracle . TextFile
+
+-- | Lookup a value in a text file, tracking the result. Each line of the file
+-- is expected to have @key = value@ format.
+lookupValue :: FilePath -> String -> Action (Maybe String)
+lookupValue file key = askOracle $ KeyValue (file, key)
+
+-- | Like 'lookupValue' but returns the empty string if the key is not found.
+lookupValueOrEmpty :: FilePath -> String -> Action String
+lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key
+
+-- | Like 'lookupValue' but raises an error if the key is not found.
+lookupValueOrError :: FilePath -> String -> Action String
+lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key
+  where
+    msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | Lookup a list of values in a text file, tracking the result. Each line of
+-- the file is expected to have @key value1 value2 ...@ format.
+lookupValues :: FilePath -> String -> Action (Maybe [String])
+lookupValues file key = askOracle $ KeyValues (file, key)
+
+-- | Like 'lookupValues' but returns the empty list if the key is not found.
+lookupValuesOrEmpty :: FilePath -> String -> Action [String]
+lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key
+
+-- | Like 'lookupValues' but raises an error if the key is not found.
+lookupValuesOrError :: FilePath -> String -> Action [String]
+lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key
+  where
+    msg = "Key " ++ quote key ++ " not found in file " ++ quote file
+
+-- | The 'Action' @lookupDependencies depFile file@ looks up dependencies of a
+-- @file@ in a (typically generated) dependency file @depFile@. The action
+-- returns a pair @(source, files)@, such that the @file@ can be produced by
+-- compiling @source@, which in turn also depends on a number of other @files@.
+lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath])
+lookupDependencies depFile file = do
+    deps <- lookupValues depFile file
+    case deps of
+        Nothing -> error $ "No dependencies found for file " ++ quote file
+        Just [] -> error $ "No source file found for file " ++ quote file
+        Just (source : files) -> return (source, files)
+
+-- | Read and parse a @.cabal@ file, caching and tracking the result.
+readCabalFile :: FilePath -> Action Cabal
+readCabalFile = askOracle . CabalFile
+
+-- | This oracle reads and parses text files to answer 'readTextFile' and
+-- 'lookupValue' queries, as well as their derivatives, tracking the results.
+textFileOracle :: Rules ()
+textFileOracle = do
+    text <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| TextFile oracle: reading " ++ quote file ++ "..."
+        liftIO $ readFile file
+    void $ addOracle $ \(TextFile file) -> text file
+
+    kv <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| KeyValue oracle: reading " ++ quote file ++ "..."
+        liftIO $ readConfigFile file
+    void $ addOracle $ \(KeyValue (file, key)) -> Map.lookup key <$> kv file
+
+    kvs <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| KeyValues oracle: reading " ++ quote file ++ "..."
+        contents <- map words <$> readFileLines file
+        return $ Map.fromList [ (key, values) | (key:values) <- contents ]
+    void $ addOracle $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file
+
+    cabal <- newCache $ \file -> do
+        need [file]
+        putLoud $ "| CabalFile oracle: reading " ++ quote file ++ "..."
+        liftIO $ parseCabal file
+    void $ addOracle $ \(CabalFile file) -> cabal file
diff --git a/hadrian/src/Hadrian/Package.hs b/hadrian/src/Hadrian/Package.hs
new file mode 100644
index 0000000000..11a6998f65
--- /dev/null
+++ b/hadrian/src/Hadrian/Package.hs
@@ -0,0 +1,120 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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, PackageLanguage, PackageType,
+
+    -- * Construction and properties
+    cLibrary, cProgram, hsLibrary, hsProgram,
+    isLibrary, isProgram, isCPackage, isHsPackage,
+
+    -- * Package directory structure
+    pkgCabalFile, unsafePkgCabalFile
+    ) where
+
+import Data.Maybe
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import GHC.Generics
+import GHC.Stack
+import Hadrian.Utilities
+
+data PackageLanguage = C | Haskell deriving (Generic, Show)
+
+-- TODO: Make PackageType more precise.
+-- See https://github.com/snowleopard/hadrian/issues/12.
+data PackageType = Library | Program deriving (Generic, Show)
+
+type PackageName = String
+
+-- TODO: Consider turning Package into a GADT indexed with language and type.
+data Package = Package {
+    -- | The package language. 'C' and 'Haskell' packages are supported.
+    pkgLanguage :: PackageLanguage,
+    -- | 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 (Generic, Show)
+
+instance Eq Package where
+    p == q = pkgName p == pkgName q
+
+instance Ord Package where
+    compare p q = compare (pkgName p) (pkgName q)
+
+instance Binary   PackageLanguage
+instance Hashable PackageLanguage
+instance NFData   PackageLanguage
+
+instance Binary   PackageType
+instance Hashable PackageType
+instance NFData   PackageType
+
+instance Binary   Package
+instance Hashable Package
+instance NFData   Package
+
+-- | Construct a C library package.
+cLibrary :: PackageName -> FilePath -> Package
+cLibrary = Package C Library
+
+-- | Construct a C program package.
+cProgram :: PackageName -> FilePath -> Package
+cProgram = Package C Program
+
+-- | Construct a Haskell library package.
+hsLibrary :: PackageName -> FilePath -> Package
+hsLibrary = Package Haskell Library
+
+-- | Construct a Haskell program package.
+hsProgram :: PackageName -> FilePath -> Package
+hsProgram = Package Haskell Program
+
+-- | 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
+
+-- | Is this a C package?
+isCPackage :: Package -> Bool
+isCPackage (Package C _ _ _) = True
+isCPackage _ = False
+
+-- | Is this a Haskell package?
+isHsPackage :: Package -> Bool
+isHsPackage (Package Haskell _ _ _) = True
+isHsPackage _ = False
+
+-- | The path to the Cabal file of a Haskell package, e.g. @ghc/ghc-bin.cabal@,
+-- or @Nothing@ if the argument is not a Haskell package.
+pkgCabalFile :: Package -> Maybe FilePath
+pkgCabalFile p | isHsPackage p = Just $ pkgPath p -/- pkgName p <.> "cabal"
+               | otherwise     = Nothing
+
+-- | Like 'pkgCabalFile' but raises an error on a non-Haskell package.
+unsafePkgCabalFile :: HasCallStack => Package -> FilePath
+unsafePkgCabalFile p = fromMaybe (error msg) (pkgCabalFile p)
+  where
+    msg = "[unsafePkgCabalFile] Not a Haskell package: " ++ show p
diff --git a/hadrian/src/Hadrian/Target.hs b/hadrian/src/Hadrian/Target.hs
new file mode 100644
index 0000000000..88489776c0
--- /dev/null
+++ b/hadrian/src/Hadrian/Target.hs
@@ -0,0 +1,29 @@
+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)
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
new file mode 100644
index 0000000000..1cd22b1179
--- /dev/null
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -0,0 +1,406 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hadrian.Utilities (
+    -- * List manipulation
+    fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
+
+    -- * String manipulation
+    quote, yesNo,
+
+    -- * FilePath manipulation
+    unifyPath, (-/-),
+
+    -- * Accessing Shake's type-indexed map
+    insertExtra, lookupExtra, userSetting,
+
+    -- * Paths
+    BuildRoot (..), buildRoot, isGeneratedSource,
+
+    -- * File system operations
+    copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
+    createDirectory, copyDirectory, moveDirectory, removeDirectory,
+
+    -- * Diagnostic info
+    UseColour (..), putColoured, BuildProgressColour (..), putBuild,
+    SuccessColour (..), putSuccess, ProgressInfo (..),
+    putProgressInfo, renderAction, 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.Extra
+import Data.Maybe
+import Data.Typeable (TypeRep, typeOf)
+import Development.Shake hiding (Normal)
+import Development.Shake.Classes
+import Development.Shake.FilePath
+import System.Console.ANSI
+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"
+
+-- | 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 = b
+a  -/- b
+    | last a == '/' = a ++       b
+    | otherwise     = a ++ '/' : b
+
+infixr 6 -/-
+
+-- | 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
+
+newtype BuildRoot = BuildRoot FilePath deriving Typeable
+
+-- | All build results are put into the 'buildRoot' directory.
+buildRoot :: Action FilePath
+buildRoot = do
+    BuildRoot path <- userSetting (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)
+
+-- | A more colourful version of Shake's 'putNormal'.
+putColoured :: ColorIntensity -> Color -> String -> Action ()
+putColoured intensity colour msg = do
+    useColour <- userSetting Never
+    supported <- liftIO $ hSupportsANSI IO.stdout
+    let c Never  = False
+        c Auto   = supported || IO.isWindows -- Colours do work on Windows
+        c Always = True
+    when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
+    putNormal msg
+    when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
+
+newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'BuildProgressColour'.
+magenta :: BuildProgressColour
+magenta = BuildProgressColour (Dull, Magenta)
+
+-- | Print a build progress message (e.g. executing a build command).
+putBuild :: String -> Action ()
+putBuild msg = do
+    BuildProgressColour (intensity, colour) <- userSetting magenta
+    putColoured intensity colour msg
+
+newtype SuccessColour = SuccessColour (ColorIntensity, Color)
+    deriving Typeable
+
+-- | Default 'SuccessColour'.
+green :: SuccessColour
+green = SuccessColour (Dull, Green)
+
+-- | Print a success message (e.g. a package is built successfully).
+putSuccess :: String -> Action ()
+putSuccess msg = do
+    SuccessColour (intensity, colour) <- userSetting green
+    putColoured intensity colour 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 the successful build of a program.
+renderProgram :: String -> String -> Maybe String -> String
+renderProgram name bin synopsis = renderBox $
+    [ "Successfully built program " ++ name
+    , "Executable: " ++ bin ] ++
+    [ "Program synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+-- | Render the successful build of a library.
+renderLibrary :: String -> String -> Maybe String -> String
+renderLibrary name lib synopsis = renderBox $
+    [ "Successfully built library " ++ name
+    , "Library: " ++ lib ] ++
+    [ "Library synopsis: " ++ prettySynopsis synopsis | isJust synopsis ]
+
+prettySynopsis :: Maybe String -> String
+prettySynopsis Nothing  = ""
+prettySynopsis (Just 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)