Distribution/Simple/Utils.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE BangPatterns #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.Simple.Utils
    -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
    -- License     :  BSD3
    --                portions Copyright (c) 2007, Galois Inc.
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- A large and somewhat miscellaneous collection of utility functions used
    -- throughout the rest of the Cabal lib and in other tools that use the Cabal
    -- lib like @cabal-install@. It has a very simple set of logging actions. It
    -- has low level functions for running programs, a bunch of wrappers for
    -- various directory and file functions that do extra logging.

    module Distribution.Simple.Utils (
            cabalVersion,

            -- * logging and errors
            -- Old style
            die, dieWithLocation,
            -- New style
            dieNoVerbosity,
            die', dieWithLocation',
            dieNoWrap,
            topHandler, topHandlerWith,
            warn,
            notice, noticeNoWrap, noticeDoc,
            setupMessage,
            info, infoNoWrap,
            debug, debugNoWrap,
            chattyTry,
            printRawCommandAndArgs, printRawCommandAndArgsAndEnv,

            -- * exceptions
            handleDoesNotExist,

            -- * running programs
            rawSystemExit,
            rawSystemExitCode,
            rawSystemExitWithEnv,
            rawSystemStdout,
            rawSystemStdInOut,
            rawSystemIOWithEnv,
            createProcessWithEnv,
            maybeExit,
            xargs,
            findProgramLocation,
            findProgramVersion,

            -- * copying files
            smartCopySources,
            createDirectoryIfMissingVerbose,
            copyFileVerbose,
            copyDirectoryRecursiveVerbose,
            copyFiles,
            copyFileTo,

            -- * installing files
            installOrdinaryFile,
            installExecutableFile,
            installMaybeExecutableFile,
            installOrdinaryFiles,
            installExecutableFiles,
            installMaybeExecutableFiles,
            installDirectoryContents,
            copyDirectoryRecursive,

            -- * File permissions
            doesExecutableExist,
            setFileOrdinary,
            setFileExecutable,

            -- * file names
            currentDir,
            shortRelativePath,
            dropExeExtension,
            exeExtensions,

            -- * finding files
            findFile,
            findFirstFile,
            findFileWithExtension,
            findFileWithExtension',
            findAllFilesWithExtension,
            findModuleFile,
            findModuleFiles,
            getDirectoryContentsRecursive,

            -- * environment variables
            isInSearchPath,
            addLibraryPath,

            -- * simple file globbing
            matchFileGlob,
            matchDirFileGlob,
            parseFileGlob,
            FileGlob(..),

            -- * modification time
            moreRecentFile,
            existsAndIsMoreRecentThan,

            -- * temp files and dirs
            TempFileOptions(..), defaultTempFileOptions,
            withTempFile, withTempFileEx,
            withTempDirectory, withTempDirectoryEx,

            -- * .cabal and .buildinfo files
            defaultPackageDesc,
            findPackageDesc,
            tryFindPackageDesc,
            defaultHookedPackageDesc,
            findHookedPackageDesc,

            -- * reading and writing files safely
            withFileContents,
            writeFileAtomic,
            rewriteFile,

            -- * Unicode
            fromUTF8,
            fromUTF8BS,
            fromUTF8LBS,
            toUTF8,
            readUTF8File,
            withUTF8FileContents,
            writeUTF8File,
            normaliseLineEndings,

            -- * BOM
            startsWithBOM,
            fileHasBOM,
            ignoreBOM,

            -- * generic utils
            dropWhileEndLE,
            takeWhileEndLE,
            equating,
            comparing,
            isInfixOf,
            intercalate,
            lowercase,
            listUnion,
            listUnionRight,
            ordNub,
            ordNubBy,
            ordNubRight,
            safeTail,
            unintersperse,
            wrapText,
            wrapLine,

            -- * FilePath stuff
            isAbsoluteOnAnyPlatform,
            isRelativeOnAnyPlatform,
      ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Text
    import Distribution.Utils.Generic
    import Distribution.Package
    import Distribution.ModuleName as ModuleName
    import Distribution.System
    import Distribution.Version
    import Distribution.Compat.CopyFile
    import Distribution.Compat.Internal.TempFile
    import Distribution.Compat.Exception
    import Distribution.Compat.Stack
    import Distribution.Verbosity

    #if __GLASGOW_HASKELL__ < 711
    #ifdef VERSION_base
    #define BOOTSTRAPPED_CABAL 1
    #endif
    #else
    #ifdef CURRENT_PACKAGE_KEY
    #define BOOTSTRAPPED_CABAL 1
    #endif
    #endif

    #ifdef BOOTSTRAPPED_CABAL
    import qualified Paths_Cabal (version)
    #endif

    import Control.Concurrent.MVar
        ( newEmptyMVar, putMVar, takeMVar )
    import Data.Typeable
        ( cast )
    import qualified Data.ByteString.Lazy.Char8 as BS.Char8

    import System.Directory
        ( Permissions(executable), getDirectoryContents, getPermissions
        , doesDirectoryExist, doesFileExist, removeFile, findExecutable
        , getModificationTime )
    import System.Environment
        ( getProgName )
    import System.Exit
        ( exitWith, ExitCode(..) )
    import System.FilePath
        ( normalise, (</>), (<.>)
        , getSearchPath, joinPath, takeDirectory, splitFileName
        , splitExtension, splitExtensions, splitDirectories
        , searchPathSeparator )
    import System.Directory
        ( createDirectory, removeDirectoryRecursive )
    import System.IO
        ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush
        , hClose )
    import System.IO.Error
    import System.IO.Unsafe
        ( unsafeInterleaveIO )
    import qualified Control.Exception as Exception

    import Control.Exception (IOException, evaluate, throwIO)
    import Control.Concurrent (forkIO)
    import qualified System.Process as Process
             ( CreateProcess(..), StdStream(..), proc)
    import System.Process
             ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
             , showCommandForUser, waitForProcess)

    import qualified Text.PrettyPrint as Disp

    -- We only get our own version number when we're building with ourselves
    cabalVersion :: Version
    #if defined(BOOTSTRAPPED_CABAL)
    cabalVersion = mkVersion' Paths_Cabal.version
    #elif defined(CABAL_VERSION)
    cabalVersion = mkVersion [CABAL_VERSION]
    #else
    cabalVersion = mkVersion [1,9999]  --used when bootstrapping
    #endif

    -- ----------------------------------------------------------------------------
    -- Exception and logging utils

    -- Cabal's logging infrastructure has a few constraints:
    --
    --  * We must make all logging formatting and emissions decisions based
    --    on the 'Verbosity' parameter, which is the only parameter that is
    --    plumbed to enough call-sites to actually be used for this matter.
    --    (One of Cabal's "big mistakes" is to have never have defined a
    --    monad of its own.)
    --
    --  * When we 'die', we must raise an IOError.  This a backwards
    --    compatibility consideration, because that's what we've raised
    --    previously, and if we change to any other exception type,
    --    exception handlers which match on IOError will no longer work.
    --    One case where it is known we rely on IOError being catchable
    --    is 'readPkgConfigDb' in cabal-install; there may be other
    --    user code that also assumes this.
    --
    --  * The 'topHandler' does not know what 'Verbosity' is, because
    --    it gets called before we've done command line parsing (where
    --    the 'Verbosity' parameter would come from).
    --
    -- This leads to two big architectural choices:
    --
    --  * Although naively we might imagine 'Verbosity' to be a simple
    --    enumeration type, actually it is a full-on abstract data type
    --    that may contain arbitrarily complex information.  At the
    --    moment, it is fully representable as a string, but we might
    --    eventually also use verbosity to let users register their
    --    own logging handler.
    --
    --  * When we call 'die', we perform all the formatting and addition
    --    of extra information we need, and then ship this in the IOError
    --    to the top-level handler.  Here are alternate designs that
    --    don't work:
    --
    --      a) Ship the unformatted info to the handler.  This doesn't
    --      work because at the point the handler gets the message,
    --      we've lost call stacks, and even if we did, we don't have access
    --      to 'Verbosity' to decide whether or not to render it.
    --
    --      b) Print the information at the 'die' site, then raise an
    --      error.  This means that if the exception is subsequently
    --      caught by a handler, we will still have emitted the output,
    --      which is not the correct behavior.
    --
    --    For the top-level handler to "know" that an error message
    --    contains one of these fully formatted packets, we set a sentinel
    --    in one of IOError's extra fields.  This is handled by
    --    'ioeSetVerbatim' and 'ioeGetVerbatim'.
    --

    {-# DEPRECATED dieWithLocation "Messages thrown with dieWithLocation can't be controlled with Verbosity; use dieWithLocation' instead" #-}
    dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
    dieWithLocation filename lineno msg =
      ioError . setLocation lineno
              . flip ioeSetFileName (normalise filename)
              $ userError msg
      where
        setLocation Nothing  err = err
        setLocation (Just n) err = ioeSetLocation err (show n)
        _ = callStack -- TODO: Attach CallStack to exception

    {-# DEPRECATED die "Messages thrown with die can't be controlled with Verbosity; use die' instead, or dieNoVerbosity if Verbosity truly is not available" #-}
    die :: String -> IO a
    die = dieNoVerbosity

    dieNoVerbosity :: String -> IO a
    dieNoVerbosity msg
        = ioError (userError msg)
      where
        _ = callStack -- TODO: Attach CallStack to exception

    -- | Tag an 'IOError' whose error string should be output to the screen
    -- verbatim.
    ioeSetVerbatim :: IOError -> IOError
    ioeSetVerbatim e = ioeSetLocation e "dieVerbatim"

    -- | Check if an 'IOError' should be output verbatim to screen.
    ioeGetVerbatim :: IOError -> Bool
    ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim"

    -- | Create a 'userError' whose error text will be output verbatim
    verbatimUserError :: String -> IOError
    verbatimUserError = ioeSetVerbatim . userError

    dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
    dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do
        pname <- getProgName
        ioError . verbatimUserError
                . withMetadata AlwaysMark verbosity
                . wrapTextVerbosity verbosity
                $ pname ++ ": " ++
                  filename ++ (case mb_lineno of
                                Just lineno -> ":" ++ show lineno
                                Nothing -> "") ++
                  ": " ++ msg

    die' :: Verbosity -> String -> IO a
    die' verbosity msg = withFrozenCallStack $ do
        pname <- getProgName
        ioError . verbatimUserError
                . withMetadata AlwaysMark verbosity
                . wrapTextVerbosity verbosity
                $ pname ++ ": " ++ msg

    dieNoWrap :: Verbosity -> String -> IO a
    dieNoWrap verbosity msg = withFrozenCallStack $ do
        -- TODO: should this have program name or not?
        ioError . verbatimUserError
                . withMetadata AlwaysMark verbosity
                $ msg

    topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
    topHandlerWith cont prog =
        Exception.catches prog [
            Exception.Handler rethrowAsyncExceptions
          , Exception.Handler rethrowExitStatus
          , Exception.Handler handle
          ]
      where
        -- Let async exceptions rise to the top for the default top-handler
        rethrowAsyncExceptions :: Exception.AsyncException -> NoCallStackIO a
        rethrowAsyncExceptions a = throwIO a

        -- ExitCode gets thrown asynchronously too, and we don't want to print it
        rethrowExitStatus :: ExitCode -> NoCallStackIO a
        rethrowExitStatus = throwIO

        -- Print all other exceptions
        handle :: Exception.SomeException -> NoCallStackIO a
        handle se = do
          hFlush stdout
          pname <- getProgName
          hPutStr stderr (message pname se)
          cont se

        message :: String -> Exception.SomeException -> String
        message pname (Exception.SomeException se) =
          case cast se :: Maybe Exception.IOException of
            Just ioe
             | ioeGetVerbatim ioe ->
                -- Use the message verbatim
                ioeGetErrorString ioe
             | isUserError ioe ->
              let file         = case ioeGetFileName ioe of
                                   Nothing   -> ""
                                   Just path -> path ++ location ++ ": "
                  location     = case ioeGetLocation ioe of
                                   l@(n:_) | isDigit n -> ':' : l
                                   _                        -> ""
                  detail       = ioeGetErrorString ioe
              in wrapText (pname ++ ": " ++ file ++ detail)
            _ ->
              -- Why not use the default handler? Because we want
              -- to wrap the error message output.
    #if __GLASGOW_HASKELL__ < 710
              wrapText (show se)
    #else
              wrapText (Exception.displayException se)
    #endif

    topHandler :: IO a -> IO a
    topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog

    -- | Non fatal conditions that may be indicative of an error or problem.
    --
    -- We display these at the 'normal' verbosity level.
    --
    warn :: Verbosity -> String -> IO ()
    warn verbosity msg = withFrozenCallStack $ do
      when (verbosity >= normal) $ do
        hFlush stdout
        hPutStr stderr . withMetadata NormalMark verbosity
                       . wrapTextVerbosity verbosity
                       $ "Warning: " ++ msg

    -- | Useful status messages.
    --
    -- We display these at the 'normal' verbosity level.
    --
    -- This is for the ordinary helpful status messages that users see. Just
    -- enough information to know that things are working but not floods of detail.
    --
    notice :: Verbosity -> String -> IO ()
    notice verbosity msg = withFrozenCallStack $ do
      when (verbosity >= normal) $ do
        hPutStr stdout . withMetadata NormalMark verbosity
                       . wrapTextVerbosity verbosity
                       $ msg

    -- | Display a message at 'normal' verbosity level, but without
    -- wrapping.
    --
    noticeNoWrap :: Verbosity -> String -> IO ()
    noticeNoWrap verbosity msg = withFrozenCallStack $ do
      when (verbosity >= normal) $ do
        hPutStr stdout . withMetadata NormalMark verbosity $ msg

    -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
    -- level.  Use this if you need fancy formatting.
    --
    noticeDoc :: Verbosity -> Disp.Doc -> IO ()
    noticeDoc verbosity msg = withFrozenCallStack $ do
      when (verbosity >= normal) $ do
        hPutStr stdout . withMetadata NormalMark verbosity
                       . Disp.renderStyle defaultStyle $ msg

    -- | Display a "setup status message".  Prefer using setupMessage'
    -- if possible.
    --
    setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
    setupMessage verbosity msg pkgid = withFrozenCallStack $ do
        noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...")

    -- | More detail on the operation of some action.
    --
    -- We display these messages when the verbosity level is 'verbose'
    --
    info :: Verbosity -> String -> IO ()
    info verbosity msg = withFrozenCallStack $
      when (verbosity >= verbose) $ do
        hPutStr stdout . withMetadata NeverMark verbosity
                       . wrapTextVerbosity verbosity
                       $ msg

    infoNoWrap :: Verbosity -> String -> IO ()
    infoNoWrap verbosity msg = withFrozenCallStack $
      when (verbosity >= verbose) $ do
        hPutStr stdout . withMetadata NeverMark verbosity
                       $ msg

    -- | Detailed internal debugging information
    --
    -- We display these messages when the verbosity level is 'deafening'
    --
    debug :: Verbosity -> String -> IO ()
    debug verbosity msg = withFrozenCallStack $
      when (verbosity >= deafening) $ do
        hPutStr stdout . withMetadata NeverMark verbosity
                       . wrapTextVerbosity verbosity
                       $ msg
        -- ensure that we don't lose output if we segfault/infinite loop
        hFlush stdout

    -- | A variant of 'debug' that doesn't perform the automatic line
    -- wrapping. Produces better output in some cases.
    debugNoWrap :: Verbosity -> String -> IO ()
    debugNoWrap verbosity msg = withFrozenCallStack $
      when (verbosity >= deafening) $ do
        hPutStr stdout . withMetadata NeverMark verbosity
                       $ msg
        -- ensure that we don't lose output if we segfault/infinite loop
        hFlush stdout

    -- | Perform an IO action, catching any IO exceptions and printing an error
    --   if one occurs.
    chattyTry :: String  -- ^ a description of the action we were attempting
              -> IO ()   -- ^ the action itself
              -> IO ()
    chattyTry desc action =
      catchIO action $ \exception ->
        putStrLn $ "Error while " ++ desc ++ ": " ++ show exception

    -- | Run an IO computation, returning @e@ if it raises a "file
    -- does not exist" error.
    handleDoesNotExist :: a -> NoCallStackIO a -> NoCallStackIO a
    handleDoesNotExist e =
        Exception.handleJust
          (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
          (\_ -> return e)

    -- -----------------------------------------------------------------------------
    -- Helper functions

    -- | Wraps text unless the @+nowrap@ verbosity flag is active
    wrapTextVerbosity :: Verbosity -> String -> String
    wrapTextVerbosity verb
      | isVerboseNoWrap verb = withTrailingNewline
      | otherwise            = wrapText

    -- | Wrap output with a marker if @+markoutput@ verbosity flag is set.
    --
    -- NB: Why is markoutput done with start/end markers, and not prefixes?
    -- Markers are more convenient to add (if we want to add prefixes,
    -- we have to 'lines' and then 'map'; here's it's just some
    -- concatenates).  Note that even in the prefix case, we can't
    -- guarantee that the markers are unambiguous, because some of
    -- Cabal's output comes straight from external programs, where
    -- we don't have the ability to interpose on the output.
    --
    withOutputMarker :: Verbosity -> String -> String
    withOutputMarker v xs | not (isVerboseMarkOutput v) = xs
    withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly
    withOutputMarker _ xs =
        "-----BEGIN CABAL OUTPUT-----\n" ++
        withTrailingNewline xs ++
        "-----END CABAL OUTPUT-----\n"

    -- | Append a trailing newline to a string if it does not
    -- already have a trailing newline.
    --
    withTrailingNewline :: String -> String
    withTrailingNewline "" = ""
    withTrailingNewline (x:xs) = x : go x xs
      where
        go   _ (c:cs) = c : go c cs
        go '\n' "" = ""
        go   _  "" = "\n"

    -- | Prepend a call-site and/or call-stack based on Verbosity
    --
    withCallStackPrefix :: Verbosity -> String -> String
    withCallStackPrefix verbosity s = withFrozenCallStack $
        (if isVerboseCallSite verbosity
            then parentSrcLocPrefix ++
                 -- Hack: need a newline before starting output marker :(
                 if isVerboseMarkOutput verbosity
                    then "\n"
                    else ""
            else "") ++
        (if isVerboseCallStack verbosity
            then "----\n" ++ prettyCallStack callStack ++ "\n"
            else "") ++
        s

    -- | When should we output the marker?  Things like 'die'
    -- always get marked, but a 'NormalMark' will only be
    -- output if we're not a quiet verbosity.
    --
    data MarkWhen = AlwaysMark | NormalMark | NeverMark

    -- | Add all necessary metadata to a logging message
    --
    withMetadata :: MarkWhen -> Verbosity -> String -> String
    withMetadata marker verbosity x = withFrozenCallStack $
        -- NB: order matters.  Output marker first because we
        -- don't want to capture call stacks.
          withTrailingNewline
        . withCallStackPrefix verbosity
        . (case marker of
            AlwaysMark -> withOutputMarker verbosity
            NormalMark | not (isVerboseQuiet verbosity)
                       -> withOutputMarker verbosity
                       | otherwise
                       -> id
            NeverMark  -> id)
        $ x

    -- -----------------------------------------------------------------------------
    -- rawSystem variants
    maybeExit :: IO ExitCode -> IO ()
    maybeExit cmd = do
      res <- cmd
      unless (res == ExitSuccess) $ exitWith res

    printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
    printRawCommandAndArgs verbosity path args = withFrozenCallStack $
        printRawCommandAndArgsAndEnv verbosity path args Nothing

    printRawCommandAndArgsAndEnv :: Verbosity
                                 -> FilePath
                                 -> [String]
                                 -> Maybe [(String, String)]
                                 -> IO ()
    printRawCommandAndArgsAndEnv verbosity path args menv = do
        case menv of
            Just env -> debugNoWrap verbosity ("Environment: " ++ show env)
            Nothing -> return ()
        infoNoWrap verbosity (showCommandForUser path args)

    -- Exit with the same exit code if the subcommand fails
    rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
    rawSystemExit verbosity path args = withFrozenCallStack $ do
      printRawCommandAndArgs verbosity path args
      hFlush stdout
      exitcode <- rawSystem path args
      unless (exitcode == ExitSuccess) $ do
        debug verbosity $ path ++ " returned " ++ show exitcode
        exitWith exitcode

    rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
    rawSystemExitCode verbosity path args = withFrozenCallStack $ do
      printRawCommandAndArgs verbosity path args
      hFlush stdout
      exitcode <- rawSystem path args
      unless (exitcode == ExitSuccess) $ do
        debug verbosity $ path ++ " returned " ++ show exitcode
      return exitcode

    rawSystemExitWithEnv :: Verbosity
                         -> FilePath
                         -> [String]
                         -> [(String, String)]
                         -> IO ()
    rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do
        printRawCommandAndArgsAndEnv verbosity path args (Just env)
        hFlush stdout
        (_,_,_,ph) <- createProcess $
                      (Process.proc path args) { Process.env = (Just env)
    #ifdef MIN_VERSION_process
    #if MIN_VERSION_process(1,2,0)
    -- delegate_ctlc has been added in process 1.2, and we still want to be able to
    -- bootstrap GHC on systems not having that version
                                               , Process.delegate_ctlc = True
    #endif
    #endif
                                               }
        exitcode <- waitForProcess ph
        unless (exitcode == ExitSuccess) $ do
            debug verbosity $ path ++ " returned " ++ show exitcode
            exitWith exitcode

    -- Closes the passed in handles before returning.
    rawSystemIOWithEnv :: Verbosity
                       -> FilePath
                       -> [String]
                       -> Maybe FilePath           -- ^ New working dir or inherit
                       -> Maybe [(String, String)] -- ^ New environment or inherit
                       -> Maybe Handle  -- ^ stdin
                       -> Maybe Handle  -- ^ stdout
                       -> Maybe Handle  -- ^ stderr
                       -> IO ExitCode
    rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
        (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv
                                           (mbToStd inp) (mbToStd out) (mbToStd err)
        exitcode <- waitForProcess ph
        unless (exitcode == ExitSuccess) $ do
          debug verbosity $ path ++ " returned " ++ show exitcode
        return exitcode
      where
        mbToStd :: Maybe Handle -> Process.StdStream
        mbToStd = maybe Process.Inherit Process.UseHandle

    createProcessWithEnv ::
         Verbosity
      -> FilePath
      -> [String]
      -> Maybe FilePath           -- ^ New working dir or inherit
      -> Maybe [(String, String)] -- ^ New environment or inherit
      -> Process.StdStream  -- ^ stdin
      -> Process.StdStream  -- ^ stdout
      -> Process.StdStream  -- ^ stderr
      -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)
      -- ^ Any handles created for stdin, stdout, or stderr
      -- with 'CreateProcess', and a handle to the process.
    createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
        printRawCommandAndArgsAndEnv verbosity path args menv
        hFlush stdout
        (inp', out', err', ph) <- createProcess $
                                    (Process.proc path args) {
                                        Process.cwd           = mcwd
                                      , Process.env           = menv
                                      , Process.std_in        = inp
                                      , Process.std_out       = out
                                      , Process.std_err       = err
    #ifdef MIN_VERSION_process
    #if MIN_VERSION_process(1,2,0)
    -- delegate_ctlc has been added in process 1.2, and we still want to be able to
    -- bootstrap GHC on systems not having that version
                                      , Process.delegate_ctlc = True
    #endif
    #endif
                                      }
        return (inp', out', err', ph)

    -- | Run a command and return its output.
    --
    -- The output is assumed to be text in the locale encoding.
    --
    rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
    rawSystemStdout verbosity path args = withFrozenCallStack $ do
      (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
                                                      Nothing Nothing
                                                      Nothing False
      when (exitCode /= ExitSuccess) $
        die errors
      return output

    -- | Run a command and return its output, errors and exit status. Optionally
    -- also supply some input. Also provides control over whether the binary/text
    -- mode of the input and output.
    --
    rawSystemStdInOut :: Verbosity
                      -> FilePath                 -- ^ Program location
                      -> [String]                 -- ^ Arguments
                      -> Maybe FilePath           -- ^ New working dir or inherit
                      -> Maybe [(String, String)] -- ^ New environment or inherit
                      -> Maybe (String, Bool)     -- ^ input text and binary mode
                      -> Bool                     -- ^ output in binary mode
                      -> IO (String, String, ExitCode) -- ^ output, errors, exit
    rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do
      printRawCommandAndArgs verbosity path args

      Exception.bracket
         (runInteractiveProcess path args mcwd menv)
         (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
        $ \(inh,outh,errh,pid) -> do

          -- output mode depends on what the caller wants
          hSetBinaryMode outh outputBinary
          -- but the errors are always assumed to be text (in the current locale)
          hSetBinaryMode errh False

          -- fork off a couple threads to pull on the stderr and stdout
          -- so if the process writes to stderr we do not block.

          err <- hGetContents errh
          out <- hGetContents outh

          mv <- newEmptyMVar
          let force str = do
                mberr <- Exception.try (evaluate (length str) >> return ())
                putMVar mv (mberr :: Either IOError ())
          _ <- forkIO $ force out
          _ <- forkIO $ force err

          -- push all the input, if any
          case input of
            Nothing -> return ()
            Just (inputStr, inputBinary) -> do
                    -- input mode depends on what the caller wants
              hSetBinaryMode inh inputBinary
              hPutStr inh inputStr
              hClose inh
              --TODO: this probably fails if the process refuses to consume
              -- or if it closes stdin (eg if it exits)

          -- wait for both to finish, in either order
          mberr1 <- takeMVar mv
          mberr2 <- takeMVar mv

          -- wait for the program to terminate
          exitcode <- waitForProcess pid
          unless (exitcode == ExitSuccess) $
            debug verbosity $ path ++ " returned " ++ show exitcode
                           ++ if null err then "" else
                              " with error message:\n" ++ err
                           ++ case input of
                                Nothing       -> ""
                                Just ("",  _) -> ""
                                Just (inp, _) -> "\nstdin input:\n" ++ inp

          -- Check if we we hit an exception while consuming the output
          -- (e.g. a text decoding error)
          reportOutputIOError mberr1
          reportOutputIOError mberr2

          return (out, err, exitcode)
      where
        reportOutputIOError :: Either IOError () -> NoCallStackIO ()
        reportOutputIOError =
          either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))
                 return

    {-# DEPRECATED findProgramLocation
        "No longer used within Cabal, try findProgramOnSearchPath" #-}
    -- | Look for a program on the path.
    findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
    findProgramLocation verbosity prog = withFrozenCallStack $ do
      debug verbosity $ "searching for " ++ prog ++ " in path."
      res <- findExecutable prog
      case res of
          Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
          Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)
      return res

    -- | Look for a program and try to find it's version number. It can accept
    -- either an absolute path or the name of a program binary, in which case we
    -- will look for the program on the path.
    --
    findProgramVersion :: String             -- ^ version args
                       -> (String -> String) -- ^ function to select version
                                             --   number from program output
                       -> Verbosity
                       -> FilePath           -- ^ location
                       -> IO (Maybe Version)
    findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do
      str <- rawSystemStdout verbosity path [versionArg]
             `catchIO`   (\_ -> return "")
             `catchExit` (\_ -> return "")
      let version :: Maybe Version
          version = simpleParse (selectVersion str)
      case version of
          Nothing -> warn verbosity $ "cannot determine version of " ++ path
                                   ++ " :\n" ++ show str
          Just v  -> debug verbosity $ path ++ " is version " ++ display v
      return version

    -- | Like the Unix xargs program. Useful for when we've got very long command
    -- lines that might overflow an OS limit on command line length and so you
    -- need to invoke a command multiple times to get all the args in.
    --
    -- Use it with either of the rawSystem variants above. For example:
    --
    -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
    --
    xargs :: Int -> ([String] -> IO ())
          -> [String] -> [String] -> IO ()
    xargs maxSize rawSystemFun fixedArgs bigArgs =
      let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
          chunkSize = maxSize - fixedArgSize
       in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)

      where chunks len = unfoldr $ \s ->
              if null s then Nothing
                        else Just (chunk [] len s)

            chunk acc _   []     = (reverse acc,[])
            chunk acc len (s:ss)
              | len' < len = chunk (s:acc) (len-len'-1) ss
              | otherwise  = (reverse acc, s:ss)
              where len' = length s

    -- ------------------------------------------------------------
    -- * File Utilities
    -- ------------------------------------------------------------

    ----------------
    -- Finding files

    -- | Find a file by looking in a search path. The file path must match exactly.
    --
    findFile :: [FilePath]    -- ^search locations
             -> FilePath      -- ^File Name
             -> IO FilePath
    findFile searchPath fileName =
      findFirstFile id
        [ path </> fileName
        | path <- nub searchPath]
      >>= maybe (die $ fileName ++ " doesn't exist") return

    -- | Find a file by looking in a search path with one of a list of possible
    -- file extensions. The file base name should be given and it will be tried
    -- with each of the extensions in each element of the search path.
    --
    findFileWithExtension :: [String]
                          -> [FilePath]
                          -> FilePath
                          -> NoCallStackIO (Maybe FilePath)
    findFileWithExtension extensions searchPath baseName =
      findFirstFile id
        [ path </> baseName <.> ext
        | path <- nub searchPath
        , ext <- nub extensions ]

    findAllFilesWithExtension :: [String]
                              -> [FilePath]
                              -> FilePath
                              -> NoCallStackIO [FilePath]
    findAllFilesWithExtension extensions searchPath basename =
      findAllFiles id
        [ path </> basename <.> ext
        | path <- nub searchPath
        , ext <- nub extensions ]

    -- | Like 'findFileWithExtension' but returns which element of the search path
    -- the file was found in, and the file path relative to that base directory.
    --
    findFileWithExtension' :: [String]
                           -> [FilePath]
                           -> FilePath
                           -> NoCallStackIO (Maybe (FilePath, FilePath))
    findFileWithExtension' extensions searchPath baseName =
      findFirstFile (uncurry (</>))
        [ (path, baseName <.> ext)
        | path <- nub searchPath
        , ext <- nub extensions ]

    findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
    findFirstFile file = findFirst
      where findFirst []     = return Nothing
            findFirst (x:xs) = do exists <- doesFileExist (file x)
                                  if exists
                                    then return (Just x)
                                    else findFirst xs

    findAllFiles :: (a -> FilePath) -> [a] -> NoCallStackIO [a]
    findAllFiles file = filterM (doesFileExist . file)

    -- | Finds the files corresponding to a list of Haskell module names.
    --
    -- As 'findModuleFile' but for a list of module names.
    --
    findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)
                    -> [String]     -- ^ search suffixes
                    -> [ModuleName] -- ^ modules
                    -> IO [(FilePath, FilePath)]
    findModuleFiles searchPath extensions moduleNames =
      traverse (findModuleFile searchPath extensions) moduleNames

    -- | Find the file corresponding to a Haskell module name.
    --
    -- This is similar to 'findFileWithExtension'' but specialised to a module
    -- name. The function fails if the file corresponding to the module is missing.
    --
    findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)
                   -> [String]    -- ^ search suffixes
                   -> ModuleName  -- ^ module
                   -> IO (FilePath, FilePath)
    findModuleFile searchPath extensions mod_name =
          maybe notFound return
      =<< findFileWithExtension' extensions searchPath
                                 (ModuleName.toFilePath mod_name)
      where
        notFound = die $ "Error: Could not find module: " ++ display mod_name
                      ++ " with any suffix: " ++ show extensions
                      ++ " in the search path: " ++ show searchPath

    -- | List all the files in a directory and all subdirectories.
    --
    -- The order places files in sub-directories after all the files in their
    -- parent directories. The list is generated lazily so is not well defined if
    -- the source directory structure changes before the list is used.
    --
    getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
    getDirectoryContentsRecursive topdir = recurseDirectories [""]
      where
        recurseDirectories :: [FilePath] -> IO [FilePath]
        recurseDirectories []         = return []
        recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
          (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
          files' <- recurseDirectories (dirs' ++ dirs)
          return (files ++ files')

          where
            collect files dirs' []              = return (reverse files
                                                         ,reverse dirs')
            collect files dirs' (entry:entries) | ignore entry
                                                = collect files dirs' entries
            collect files dirs' (entry:entries) = do
              let dirEntry = dir </> entry
              isDirectory <- doesDirectoryExist (topdir </> dirEntry)
              if isDirectory
                then collect files (dirEntry:dirs') entries
                else collect (dirEntry:files) dirs' entries

            ignore ['.']      = True
            ignore ['.', '.'] = True
            ignore _          = False

    ------------------------
    -- Environment variables

    -- | Is this directory in the system search path?
    isInSearchPath :: FilePath -> NoCallStackIO Bool
    isInSearchPath path = fmap (elem path) getSearchPath

    addLibraryPath :: OS
                   -> [FilePath]
                   -> [(String,String)]
                   -> [(String,String)]
    addLibraryPath os paths = addEnv
      where
        pathsString = intercalate [searchPathSeparator] paths
        ldPath = case os of
                   OSX -> "DYLD_LIBRARY_PATH"
                   _   -> "LD_LIBRARY_PATH"

        addEnv [] = [(ldPath,pathsString)]
        addEnv ((key,value):xs)
          | key == ldPath =
              if null value
                 then (key,pathsString):xs
                 else (key,value ++ (searchPathSeparator:pathsString)):xs
          | otherwise     = (key,value):addEnv xs

    ----------------
    -- File globbing

    data FileGlob
       -- | No glob at all, just an ordinary file
       = NoGlob FilePath

       -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
       --    @FileGlob \"foo\/bar\" \".baz\"@
       | FileGlob FilePath String

    parseFileGlob :: FilePath -> Maybe FileGlob
    parseFileGlob filepath = case splitExtensions filepath of
      (filepath', ext) -> case splitFileName filepath' of
        (dir, "*") | '*' `elem` dir
                  || '*' `elem` ext
                  || null ext            -> Nothing
                   | null dir            -> Just (FileGlob "." ext)
                   | otherwise           -> Just (FileGlob dir ext)
        _          | '*' `elem` filepath -> Nothing
                   | otherwise           -> Just (NoGlob filepath)

    matchFileGlob :: FilePath -> IO [FilePath]
    matchFileGlob = matchDirFileGlob "."

    matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
    matchDirFileGlob dir filepath = case parseFileGlob filepath of
      Nothing -> die $ "invalid file glob '" ++ filepath
                    ++ "'. Wildcards '*' are only allowed in place of the file"
                    ++ " name, not in the directory name or file extension."
                    ++ " If a wildcard is used it must be with an file extension."
      Just (NoGlob filepath') -> return [filepath']
      Just (FileGlob dir' ext) -> do
        files <- getDirectoryContents (dir </> dir')
        case   [ dir' </> file
               | file <- files
               , let (name, ext') = splitExtensions file
               , not (null name) && ext' == ext ] of
          []      -> die $ "filepath wildcard '" ++ filepath
                        ++ "' does not match any files."
          matches -> return matches

    --------------------
    -- Modification time

    -- | Compare the modification times of two files to see if the first is newer
    -- than the second. The first file must exist but the second need not.
    -- The expected use case is when the second file is generated using the first.
    -- In this use case, if the result is True then the second file is out of date.
    --
    moreRecentFile :: FilePath -> FilePath -> NoCallStackIO Bool
    moreRecentFile a b = do
      exists <- doesFileExist b
      if not exists
        then return True
        else do tb <- getModificationTime b
                ta <- getModificationTime a
                return (ta > tb)

    -- | Like 'moreRecentFile', but also checks that the first file exists.
    existsAndIsMoreRecentThan :: FilePath -> FilePath -> NoCallStackIO Bool
    existsAndIsMoreRecentThan a b = do
      exists <- doesFileExist a
      if not exists
        then return False
        else a `moreRecentFile` b

    ----------------------------------------
    -- Copying and installing files and dirs

    -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
    --
    createDirectoryIfMissingVerbose :: Verbosity
                                    -> Bool     -- ^ Create its parents too?
                                    -> FilePath
                                    -> IO ()
    createDirectoryIfMissingVerbose verbosity create_parents path0
      | create_parents = withFrozenCallStack $ createDirs (parents path0)
      | otherwise      = withFrozenCallStack $ createDirs (take 1 (parents path0))
      where
        parents = reverse . scanl1 (</>) . splitDirectories . normalise

        createDirs []         = return ()
        createDirs (dir:[])   = createDir dir throwIO
        createDirs (dir:dirs) =
          createDir dir $ \_ -> do
            createDirs dirs
            createDir dir throwIO

        createDir :: FilePath -> (IOException -> IO ()) -> IO ()
        createDir dir notExistHandler = do
          r <- tryIO $ createDirectoryVerbose verbosity dir
          case (r :: Either IOException ()) of
            Right ()                   -> return ()
            Left  e
              | isDoesNotExistError  e -> notExistHandler e
              -- createDirectory (and indeed POSIX mkdir) does not distinguish
              -- between a dir already existing and a file already existing. So we
              -- check for it here. Unfortunately there is a slight race condition
              -- here, but we think it is benign. It could report an exception in
              -- the case that the dir did exist but another process deletes the
              -- directory and creates a file in its place before we can check
              -- that the directory did indeed exist.
              | isAlreadyExistsError e -> (do
                  isDir <- doesDirectoryExist dir
                  if isDir then return ()
                           else throwIO e
                  ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
              | otherwise              -> throwIO e

    createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
    createDirectoryVerbose verbosity dir = withFrozenCallStack $ do
      info verbosity $ "creating " ++ dir
      createDirectory dir
      setDirOrdinary dir

    -- | Copies a file without copying file permissions. The target file is created
    -- with default permissions. Any existing target file is replaced.
    --
    -- At higher verbosity levels it logs an info message.
    --
    copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
    copyFileVerbose verbosity src dest = withFrozenCallStack $ do
      info verbosity ("copy " ++ src ++ " to " ++ dest)
      copyFile src dest

    -- | Install an ordinary file. This is like a file copy but the permissions
    -- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
    -- while on Windows it uses the default permissions for the target directory.
    --
    installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
    installOrdinaryFile verbosity src dest = withFrozenCallStack $ do
      info verbosity ("Installing " ++ src ++ " to " ++ dest)
      copyOrdinaryFile src dest

    -- | Install an executable file. This is like a file copy but the permissions
    -- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
    -- while on Windows it uses the default permissions for the target directory.
    --
    installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
    installExecutableFile verbosity src dest = withFrozenCallStack $ do
      info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
      copyExecutableFile src dest

    -- | Install a file that may or not be executable, preserving permissions.
    installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
    installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do
      perms <- getPermissions src
      if (executable perms) --only checks user x bit
        then installExecutableFile verbosity src dest
        else installOrdinaryFile   verbosity src dest

    -- | Given a relative path to a file, copy it to the given directory, preserving
    -- the relative path and creating the parent directories if needed.
    copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
    copyFileTo verbosity dir file = withFrozenCallStack $ do
      let targetFile = dir </> file
      createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)
      installOrdinaryFile verbosity file targetFile

    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
    copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
                  -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
    copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do

      -- Create parent directories for everything
      let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
      traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs

      -- Copy all the files
      sequence_ [ let src  = srcBase   </> srcFile
                      dest = targetDir </> srcFile
                   in doCopy verbosity src dest
                | (srcBase, srcFile) <- srcFiles ]

    -- | Copies a bunch of files to a target directory, preserving the directory
    -- structure in the target location. The target directories are created if they
    -- do not exist.
    --
    -- The files are identified by a pair of base directory and a path relative to
    -- that base. It is only the relative part that is preserved in the
    -- destination.
    --
    -- For example:
    --
    -- > copyFiles normal "dist/src"
    -- >    [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]
    --
    -- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and
    -- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".
    --
    -- This operation is not atomic. Any IO failure during the copy (including any
    -- missing source files) leaves the target in an unknown state so it is best to
    -- use it with a freshly created directory so that it can be simply deleted if
    -- anything goes wrong.
    --
    copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
    copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)

    -- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
    --
    installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
    installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)

    -- | This is like 'copyFiles' but uses 'installExecutableFile'.
    --
    installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
                              -> IO ()
    installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)

    -- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.
    --
    installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
                                   -> IO ()
    installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)

    -- | This installs all the files in a directory to a target location,
    -- preserving the directory layout. All the files are assumed to be ordinary
    -- rather than executable files.
    --
    installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
    installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do
      info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
      srcFiles <- getDirectoryContentsRecursive srcDir
      installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]

    -- | Recursively copy the contents of one directory to another path.
    copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()
    copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do
      info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
      srcFiles <- getDirectoryContentsRecursive srcDir
      copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)
                                                       | f <- srcFiles ]

    -------------------
    -- File permissions

    -- | Like 'doesFileExist', but also checks that the file is executable.
    doesExecutableExist :: FilePath -> NoCallStackIO Bool
    doesExecutableExist f = do
      exists <- doesFileExist f
      if exists
        then do perms <- getPermissions f
                return (executable perms)
        else return False

    ---------------------------------
    -- Deprecated file copy functions

    {-# DEPRECATED smartCopySources
          "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-}
    smartCopySources :: Verbosity -> [FilePath] -> FilePath
                     -> [ModuleName] -> [String] -> IO ()
    smartCopySources verbosity searchPath targetDir moduleNames extensions = withFrozenCallStack $
          findModuleFiles searchPath extensions moduleNames
      >>= copyFiles verbosity targetDir

    {-# DEPRECATED copyDirectoryRecursiveVerbose
          "You probably want installDirectoryContents instead" #-}
    copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
    copyDirectoryRecursiveVerbose verbosity srcDir destDir = withFrozenCallStack $ do
      info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
      srcFiles <- getDirectoryContentsRecursive srcDir
      copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]

    ---------------------------
    -- Temporary files and dirs

    -- | Advanced options for 'withTempFile' and 'withTempDirectory'.
    data TempFileOptions = TempFileOptions {
      optKeepTempFiles :: Bool  -- ^ Keep temporary files?
      }

    defaultTempFileOptions :: TempFileOptions
    defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }

    -- | Use a temporary filename that doesn't already exist.
    --
    withTempFile :: FilePath    -- ^ Temp dir to create the file in
                    -> String   -- ^ File name template. See 'openTempFile'.
                    -> (FilePath -> Handle -> IO a) -> IO a
    withTempFile tmpDir template action =
      withTempFileEx defaultTempFileOptions tmpDir template action

    -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
    -- argument.
    withTempFileEx :: TempFileOptions
                     -> FilePath -- ^ Temp dir to create the file in
                     -> String   -- ^ File name template. See 'openTempFile'.
                     -> (FilePath -> Handle -> IO a) -> IO a
    withTempFileEx opts tmpDir template action =
      Exception.bracket
        (openTempFile tmpDir template)
        (\(name, handle) -> do hClose handle
                               unless (optKeepTempFiles opts) $
                                 handleDoesNotExist () . removeFile $ name)
        (withLexicalCallStack (uncurry action))

    -- | Create and use a temporary directory.
    --
    -- Creates a new temporary directory inside the given directory, making use
    -- of the template. The temp directory is deleted after use. For example:
    --
    -- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
    --
    -- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
    -- @src/sdist.342@.
    --
    withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a
    withTempDirectory verbosity targetDir template f = withFrozenCallStack $
      withTempDirectoryEx verbosity defaultTempFileOptions targetDir template
        (withLexicalCallStack f)

    -- | A version of 'withTempDirectory' that additionally takes a
    -- 'TempFileOptions' argument.
    withTempDirectoryEx :: Verbosity -> TempFileOptions
                           -> FilePath -> String -> (FilePath -> IO a) -> IO a
    withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $
      Exception.bracket
        (createTempDirectory targetDir template)
        (unless (optKeepTempFiles opts)
         . handleDoesNotExist () . removeDirectoryRecursive)
        (withLexicalCallStack f)

    -----------------------------------
    -- Safely reading and writing files

    -- | Write a file but only if it would have new content. If we would be writing
    -- the same as the existing content then leave the file as is so that we do not
    -- update the file's modification time.
    --
    -- NB: the file is assumed to be ASCII-encoded.
    rewriteFile :: FilePath -> String -> IO ()
    rewriteFile path newContent =
      flip catchIO mightNotExist $ do
        existingContent <- readFile path
        _ <- evaluate (length existingContent)
        unless (existingContent == newContent) $
          writeFileAtomic path (BS.Char8.pack newContent)
      where
        mightNotExist e | isDoesNotExistError e = writeFileAtomic path
                                                  (BS.Char8.pack newContent)
                        | otherwise             = ioError e
        _ = callStack -- TODO: attach call stack to exception

    -- | The path name that represents the current directory.
    -- In Unix, it's @\".\"@, but this is system-specific.
    -- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)
    currentDir :: FilePath
    currentDir = "."

    shortRelativePath :: FilePath -> FilePath -> FilePath
    shortRelativePath from to =
        case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
            (stuff, path) -> joinPath (map (const "..") stuff ++ path)
      where
        dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])
        dropCommonPrefix (x:xs) (y:ys)
            | x == y    = dropCommonPrefix xs ys
        dropCommonPrefix xs ys = (xs,ys)

    -- | Drop the extension if it's one of 'exeExtensions', or return the path
    -- unchanged.
    dropExeExtension :: FilePath -> FilePath
    dropExeExtension filepath =
      case splitExtension filepath of
        (filepath', extension) | extension `elem` exeExtensions -> filepath'
                               | otherwise                      -> filepath

    -- | List of possible executable file extensions on the current platform.
    exeExtensions :: [String]
    exeExtensions = case buildOS of
      -- Possible improvement: on Windows, read the list of extensions from the
      -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;
      -- .cmd".
      Windows -> ["", "exe"]
      Ghcjs   -> ["", "exe"]
      _       -> [""]

    -- ------------------------------------------------------------
    -- * Finding the description file
    -- ------------------------------------------------------------

    -- |Package description file (/pkgname/@.cabal@)
    defaultPackageDesc :: Verbosity -> IO FilePath
    defaultPackageDesc _verbosity = tryFindPackageDesc currentDir

    -- |Find a package description file in the given directory.  Looks for
    -- @.cabal@ files.
    findPackageDesc :: FilePath                    -- ^Where to look
                    -> NoCallStackIO (Either String FilePath) -- ^<pkgname>.cabal
    findPackageDesc dir
     = do files <- getDirectoryContents dir
          -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
          -- file we filter to exclude dirs and null base file names:
          cabalFiles <- filterM doesFileExist
                           [ dir </> file
                           | file <- files
                           , let (name, ext) = splitExtension file
                           , not (null name) && ext == ".cabal" ]
          case cabalFiles of
            []          -> return (Left  noDesc)
            [cabalFile] -> return (Right cabalFile)
            multiple    -> return (Left  $ multiDesc multiple)

      where
        noDesc :: String
        noDesc = "No cabal file found.\n"
                 ++ "Please create a package description file <pkgname>.cabal"

        multiDesc :: [String] -> String
        multiDesc l = "Multiple cabal files found.\n"
                      ++ "Please use only one of: "
                      ++ intercalate ", " l

    -- |Like 'findPackageDesc', but calls 'die' in case of error.
    tryFindPackageDesc :: FilePath -> IO FilePath
    tryFindPackageDesc dir = either die return =<< findPackageDesc dir

    -- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
    defaultHookedPackageDesc :: IO (Maybe FilePath)
    defaultHookedPackageDesc = findHookedPackageDesc currentDir

    -- |Find auxiliary package information in the given directory.
    -- Looks for @.buildinfo@ files.
    findHookedPackageDesc
        :: FilePath                 -- ^Directory to search
        -> IO (Maybe FilePath)      -- ^/dir/@\/@/pkgname/@.buildinfo@, if present
    findHookedPackageDesc dir = do
        files <- getDirectoryContents dir
        buildInfoFiles <- filterM doesFileExist
                            [ dir </> file
                            | file <- files
                            , let (name, ext) = splitExtension file
                            , not (null name) && ext == buildInfoExt ]
        case buildInfoFiles of
            [] -> return Nothing
            [f] -> return (Just f)
            _ -> die ("Multiple files with extension " ++ buildInfoExt)

    buildInfoExt  :: String
    buildInfoExt = ".buildinfo"