{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# 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
        dieNoVerbosity,
        die', dieWithLocation',
        dieNoWrap,
        topHandler, topHandlerWith,
        warn,
        notice, noticeNoWrap, noticeDoc,
        setupMessage,
        info, infoNoWrap,
        debug, debugNoWrap,
        chattyTry,
        annotateIO,
        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
        withOutputMarker,

        -- * exceptions
        handleDoesNotExist,

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

        -- ** 'IOData' re-export
        --
        -- These types are re-exported from
        -- "Distribution.Utils.IOData" for convience as they're
        -- exposed in the API of 'rawSystemStdInOut'
        IOData(..),
        KnownIODataMode (..),
        IODataMode (..),

        -- * copying files
        createDirectoryIfMissingVerbose,
        copyFileVerbose,
        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
        findFileEx,
        findFirstFile,
        findFileWithExtension,
        findFileWithExtension',
        findAllFilesWithExtension,
        findModuleFileEx,
        findModuleFilesEx,
        getDirectoryContentsRecursive,

        -- * environment variables
        isInSearchPath,
        addLibraryPath,

        -- * modification time
        moreRecentFile,
        existsAndIsMoreRecentThan,

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

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

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

        -- * Unicode
        fromUTF8BS,
        fromUTF8LBS,
        toUTF8BS,
        toUTF8LBS,
        readUTF8File,
        withUTF8FileContents,
        writeUTF8File,
        normaliseLineEndings,

        -- * BOM
        ignoreBOM,

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

        -- * FilePath stuff
        isAbsoluteOnAnyPlatform,
        isRelativeOnAnyPlatform,

        -- * Deprecated functions
        findFile,
        findModuleFile,
        findModuleFiles,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Utils.Generic
import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..))
import qualified Distribution.Utils.IOData as IOData
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
import Distribution.Compat.Async
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Exception
import Distribution.Compat.FilePath as FilePath
import Distribution.Compat.Stack
import Distribution.Verbosity
import Distribution.Types.PackageId

#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 Distribution.Pretty
import Distribution.Parsec

import Data.Typeable
    ( cast )
import qualified Data.ByteString.Lazy as BS

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

import Foreign.C.Error (Errno (..), ePIPE)
import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Control.Exception (IOException, evaluate, throwIO, fromException)
import Numeric (showFFloat)
import Distribution.Compat.Process  (createProcess, rawSystem, runInteractiveProcess)
import System.Process
         ( ProcessHandle
         , showCommandForUser, waitForProcess)
import qualified System.Process as Process
import qualified GHC.IO.Exception as GHC

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 :: Version
cabalVersion = Version -> Version
mkVersion' Version
Paths_Cabal.version
#elif defined(CABAL_VERSION)
cabalVersion = mkVersion [CABAL_VERSION]
#else
cabalVersion = mkVersion [3,0]  --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'.
--

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

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

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

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

dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
dieWithLocation' :: Verbosity -> String -> Maybe Int -> String -> IO a
dieWithLocation' Verbosity
verbosity String
filename Maybe Int
mb_lineno String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    String
pname <- IO String
getProgName
    IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
            (String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
            (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case Maybe Int
mb_lineno of
                            Just Int
lineno -> String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
lineno
                            Maybe Int
Nothing -> String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

die' :: Verbosity -> String -> IO a
die' :: Verbosity -> String -> IO a
die' Verbosity
verbosity String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    String
pname <- IO String
getProgName
    IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
            (String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
            (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap Verbosity
verbosity String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    -- TODO: should this have program name or not?
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
            (String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
            (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
msg

-- | Given a block of IO code that may raise an exception, annotate
-- it with the metadata from the current scope.  Use this as close
-- to external code that raises IO exceptions as possible, since
-- this function unconditionally wraps the error message with a trace
-- (so it is NOT idempotent.)
annotateIO :: Verbosity -> IO a -> IO a
annotateIO :: Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity IO a
act = do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    (IOError -> IOError) -> IO a -> IO a
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError (POSIXTime -> IOError -> IOError
f POSIXTime
ts) IO a
IO a
act
  where
    f :: POSIXTime -> IOError -> IOError
f POSIXTime
ts IOError
ioe = IOError -> String -> IOError
ioeSetErrorString IOError
ioe
             (String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
VerboseTrace Verbosity
verbosity
             (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ IOError -> String
ioeGetErrorString IOError
ioe


{-# NOINLINE topHandlerWith #-}
topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
topHandlerWith :: (SomeException -> IO a) -> IO a -> IO a
topHandlerWith SomeException -> IO a
cont IO a
prog = do
    -- By default, stderr to a terminal device is NoBuffering. But this
    -- is *really slow*
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
    IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
Exception.catches IO a
IO a
prog [
        (AsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler AsyncException -> IO a
rethrowAsyncExceptions
      , (ExitCode -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler ExitCode -> IO a
rethrowExitStatus
      , (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler SomeException -> IO a
handle
      ]
  where
    -- Let async exceptions rise to the top for the default top-handler
    rethrowAsyncExceptions :: Exception.AsyncException -> NoCallStackIO a
    rethrowAsyncExceptions :: AsyncException -> IO a
rethrowAsyncExceptions AsyncException
a = AsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO AsyncException
a

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

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

    message :: String -> Exception.SomeException -> String
    message :: String -> SomeException -> String
message String
pname (Exception.SomeException e
se) =
      case e -> Maybe IOError
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
se :: Maybe Exception.IOException of
        Just IOError
ioe
         | IOError -> Bool
ioeGetVerbatim IOError
ioe ->
            -- Use the message verbatim
            IOError -> String
ioeGetErrorString IOError
ioe String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
         | IOError -> Bool
isUserError IOError
ioe ->
          let file :: String
file         = case IOError -> Maybe String
ioeGetFileName IOError
ioe of
                               Maybe String
Nothing   -> String
""
                               Just String
path -> String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
location String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
              location :: String
location     = case IOError -> String
ioeGetLocation IOError
ioe of
                               l :: String
l@(Char
n:String
_) | Char -> Bool
isDigit Char
n -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
l
                               String
_                        -> String
""
              detail :: String
detail       = IOError -> String
ioeGetErrorString IOError
ioe
          in String -> String
wrapText (String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
detail)
        Maybe IOError
_ ->
          e -> String
forall e. Exception e => e -> String
displaySomeException e
se String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | BC wrapper around 'Exception.displayException'.
displaySomeException :: Exception.Exception e => e -> String
displaySomeException :: e -> String
displaySomeException e
se =
#if __GLASGOW_HASKELL__ < 710
    show se
#else
    e -> String
forall e. Exception e => e -> String
Exception.displayException e
se
#endif

topHandler :: IO a -> IO a
topHandler :: IO a -> IO a
topHandler IO a
prog = (SomeException -> IO a) -> IO a -> IO a
forall a. (SomeException -> IO a) -> IO a -> IO a
topHandlerWith (IO a -> SomeException -> IO a
forall a b. a -> b -> a
const (IO a -> SomeException -> IO a) -> IO a -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) IO a
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 -> String -> IO ()
warn Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> IO ()
hFlush Handle
stdout
    Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 -> String -> IO ()
notice Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg

-- | Display a message at 'normal' verbosity level, but without
-- wrapping.
--
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
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 -> Doc -> IO ()
noticeDoc Verbosity
verbosity Doc
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (Doc -> String) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> String) -> (Doc -> String) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Doc -> String
Disp.renderStyle Style
defaultStyle (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
msg

-- | Display a "setup status message".  Prefer using setupMessage'
-- if possible.
--
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage Verbosity
verbosity String
msg PackageIdentifier
pkgid = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
: PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...")

-- | More detail on the operation of some action.
--
-- We display these messages when the verbosity level is 'verbose'
--
info :: Verbosity -> String -> IO ()
info :: Verbosity -> String -> IO ()
info Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg

infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg

-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
--
debug :: Verbosity -> String -> IO ()
debug :: Verbosity -> String -> IO ()
debug Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
    -- ensure that we don't lose output if we segfault/infinite loop
    Handle -> IO ()
hFlush Handle
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 -> String -> IO ()
debugNoWrap Verbosity
verbosity String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    POSIXTime
ts <- IO POSIXTime
getPOSIXTime
    Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
    -- ensure that we don't lose output if we segfault/infinite loop
    Handle -> IO ()
hFlush Handle
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 :: String -> IO () -> IO ()
chattyTry String
desc IO ()
action =
  IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catchIO IO ()
IO ()
action ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOError
exception ->
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error while " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
exception

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

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

-- | Wraps text unless the @+nowrap@ verbosity flag is active
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity Verbosity
verb
  | Verbosity -> Bool
isVerboseNoWrap Verbosity
verb = String -> String
withTrailingNewline
  | Bool
otherwise            = String -> String
withTrailingNewline (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
wrapText


-- | Prepends a timestamp if @+timestamp@ verbosity flag is set
--
-- This is used by 'withMetadata'
--
withTimestamp :: Verbosity -> POSIXTime -> String -> String
withTimestamp :: Verbosity -> POSIXTime -> String -> String
withTimestamp Verbosity
v POSIXTime
ts String
msg
  | Verbosity -> Bool
isVerboseTimestamp Verbosity
v  = String
msg'
  | Bool
otherwise             = String
msg -- no-op
  where
    msg' :: String
msg' = case String -> [String]
lines String
msg of
      []      -> String -> String
tsstr String
"\n"
      String
l1:[String]
rest -> [String] -> String
unlines (String -> String
tsstr (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l1) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
contpfxString -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
rest)

    -- format timestamp to be prepended to first line with msec precision
    tsstr :: String -> String
tsstr = Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3) (POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
ts :: Double)

    -- continuation prefix for subsequent lines of msg
    contpfx :: String
contpfx = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> String
tsstr String
" ")) Char
' '

-- | 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.
--
-- This is used by 'withMetadata'
--
withOutputMarker :: Verbosity -> String -> String
withOutputMarker :: Verbosity -> String -> String
withOutputMarker Verbosity
v String
xs | Bool -> Bool
not (Verbosity -> Bool
isVerboseMarkOutput Verbosity
v) = String
xs
withOutputMarker Verbosity
_ String
"" = String
"" -- Minor optimization, don't mark uselessly
withOutputMarker Verbosity
_ String
xs =
    String
"-----BEGIN CABAL OUTPUT-----\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String -> String
withTrailingNewline String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
"-----END CABAL OUTPUT-----\n"

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

-- | Prepend a call-site and/or call-stack based on Verbosity
--
withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)
withCallStackPrefix :: TraceWhen -> Verbosity -> String -> String
withCallStackPrefix TraceWhen
tracer Verbosity
verbosity String
s = (HasCallStack => String) -> String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String) -> String)
-> (HasCallStack => String) -> String
forall a b. (a -> b) -> a -> b
$
    (if Verbosity -> Bool
isVerboseCallSite Verbosity
verbosity
        then String
HasCallStack => String
parentSrcLocPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++
             -- Hack: need a newline before starting output marker :(
             if Verbosity -> Bool
isVerboseMarkOutput Verbosity
verbosity
                then String
"\n"
                else String
""
        else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (case Verbosity -> TraceWhen -> Maybe String
traceWhen Verbosity
verbosity TraceWhen
tracer of
        Just String
pre -> String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        Maybe String
Nothing  -> String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
s

-- | When should we emit the call stack?  We always emit
-- for internal errors, emit the trace for errors when we
-- are in verbose mode, and otherwise only emit it if
-- explicitly asked for using the @+callstack@ verbosity
-- flag.  (At the moment, 'AlwaysTrace' is not used.
--
data TraceWhen
    = AlwaysTrace
    | VerboseTrace
    | FlagTrace
    deriving (TraceWhen -> TraceWhen -> Bool
(TraceWhen -> TraceWhen -> Bool)
-> (TraceWhen -> TraceWhen -> Bool) -> Eq TraceWhen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceWhen -> TraceWhen -> Bool
$c/= :: TraceWhen -> TraceWhen -> Bool
== :: TraceWhen -> TraceWhen -> Bool
$c== :: TraceWhen -> TraceWhen -> Bool
Eq)

-- | Determine if we should emit a call stack.
-- If we trace, it also emits any prefix we should append.
traceWhen :: Verbosity -> TraceWhen -> Maybe String
traceWhen :: Verbosity -> TraceWhen -> Maybe String
traceWhen Verbosity
_ TraceWhen
AlwaysTrace = String -> Maybe String
forall a. a -> Maybe a
Just String
""
traceWhen Verbosity
v TraceWhen
VerboseTrace | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose         = String -> Maybe String
forall a. a -> Maybe a
Just String
""
traceWhen Verbosity
v TraceWhen
FlagTrace    | Verbosity -> Bool
isVerboseCallStack Verbosity
v = String -> Maybe String
forall a. a -> Maybe a
Just String
"----\n"
traceWhen Verbosity
_ TraceWhen
_ = Maybe String
forall a. Maybe a
Nothing

-- | 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 :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
withMetadata :: POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
marker TraceWhen
tracer Verbosity
verbosity String
x = (HasCallStack => String) -> String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String) -> String)
-> (HasCallStack => String) -> String
forall a b. (a -> b) -> a -> b
$
    -- NB: order matters.  Output marker first because we
    -- don't want to capture call stacks.
      String -> String
withTrailingNewline
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack (TraceWhen -> Verbosity -> String -> String)
TraceWhen -> Verbosity -> String -> String
withCallStackPrefix TraceWhen
tracer Verbosity
verbosity
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case MarkWhen
marker of
        MarkWhen
AlwaysMark -> Verbosity -> String -> String
withOutputMarker Verbosity
verbosity
        MarkWhen
NormalMark | Bool -> Bool
not (Verbosity -> Bool
isVerboseQuiet Verbosity
verbosity)
                   -> Verbosity -> String -> String
withOutputMarker Verbosity
verbosity
                   | Bool
otherwise
                   -> String -> String
forall a. a -> a
id
        MarkWhen
NeverMark  -> String -> String
forall a. a -> a
id)
    -- Clear out any existing markers
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clearMarkers
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> POSIXTime -> String -> String
withTimestamp Verbosity
verbosity POSIXTime
ts
    (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
x

clearMarkers :: String -> String
clearMarkers :: String -> String
clearMarkers String
s = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isMarker ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
  where
    isMarker :: String -> Bool
isMarker String
"-----BEGIN CABAL OUTPUT-----" = Bool
False
    isMarker String
"-----END CABAL OUTPUT-----"   = Bool
False
    isMarker String
_ = Bool
True

-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit :: IO ExitCode -> IO ()
maybeExit IO ExitCode
cmd = do
  ExitCode
res <- IO ExitCode
IO ExitCode
cmd
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
res ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
res



printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs :: Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing

printRawCommandAndArgsAndEnv :: Verbosity
                             -> FilePath
                             -> [String]
                             -> Maybe FilePath
                             -> Maybe [(String, String)]
                             -> IO ()
printRawCommandAndArgsAndEnv :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv = do
    case Maybe [(String, String)]
menv of
        Just [(String, String)]
env -> Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String
"Environment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
env)
        Maybe [(String, String)]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Maybe String
mcwd of
        Just String
cwd -> Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (String
"Working directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cwd)
        Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Verbosity -> String -> IO ()
infoNoWrap Verbosity
verbosity (String -> [String] -> String
showCommandForUser String
path [String]
args)

-- Exit with the same exit code if the subcommand fails
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit :: Verbosity -> String -> [String] -> IO ()
rawSystemExit Verbosity
verbosity String
path [String]
args = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args
  Handle -> IO ()
hFlush Handle
stdout
  ExitCode
exitcode <- String -> [String] -> IO ExitCode
rawSystem String
path [String]
args
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
    ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitcode

rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
rawSystemExitCode :: Verbosity -> String -> [String] -> IO ExitCode
rawSystemExitCode Verbosity
verbosity String
path [String]
args = IO ExitCode -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args
  Handle -> IO ()
hFlush Handle
stdout
  ExitCode
exitcode <- String -> [String] -> IO ExitCode
rawSystem String
path [String]
args
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
  ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode

rawSystemExitWithEnv :: Verbosity
                     -> FilePath
                     -> [String]
                     -> [(String, String)]
                     -> IO ()
rawSystemExitWithEnv :: Verbosity -> String -> [String] -> [(String, String)] -> IO ()
rawSystemExitWithEnv Verbosity
verbosity String
path [String]
args [(String, String)]
env = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
forall a. Maybe a
Nothing ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
env)
    Handle -> IO ()
hFlush Handle
stdout
    (Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
                  (String -> [String] -> CreateProcess
Process.proc String
path [String]
args) { env :: Maybe [(String, String)]
Process.env = ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
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
                                           , delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True
#endif
#endif
                                           }
    ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
        ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
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
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv Maybe Handle
inp Maybe Handle
out Maybe Handle
err = IO ExitCode -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
    (Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
ph) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv
                                       (Maybe Handle -> StdStream
mbToStd Maybe Handle
inp) (Maybe Handle -> StdStream
mbToStd Maybe Handle
out) (Maybe Handle -> StdStream
mbToStd Maybe Handle
err)
    ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
    ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode
  where
    mbToStd :: Maybe Handle -> Process.StdStream
    mbToStd :: Maybe Handle -> StdStream
mbToStd = StdStream -> (Handle -> StdStream) -> Maybe Handle -> StdStream
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
Process.Inherit Handle -> StdStream
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
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv StdStream
inp StdStream
out StdStream
err = IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv
    Handle -> IO ()
hFlush Handle
stdout
    (Maybe Handle
inp', Maybe Handle
out', Maybe Handle
err', ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
                                (String -> [String] -> CreateProcess
Process.proc String
path [String]
args) {
                                    cwd :: Maybe String
Process.cwd           = Maybe String
mcwd
                                  , env :: Maybe [(String, String)]
Process.env           = Maybe [(String, String)]
menv
                                  , std_in :: StdStream
Process.std_in        = StdStream
inp
                                  , std_out :: StdStream
Process.std_out       = StdStream
out
                                  , std_err :: StdStream
Process.std_err       = StdStream
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
                                  , delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True
#endif
#endif
                                  }
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
inp', Maybe Handle
out', Maybe Handle
err', ProcessHandle
ph)

-- | Run a command and return its output.
--
-- The output is assumed to be text in the locale encoding.
--
rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode 
rawSystemStdout :: Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity String
path [String]
args = IO mode -> IO mode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO mode -> IO mode) -> IO mode -> IO mode
forall a b. (a -> b) -> a -> b
$ do
  (mode
output, String
errors, ExitCode
exitCode) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
rawSystemStdInOut Verbosity
verbosity String
path [String]
args
    Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe IOData
forall a. Maybe a
Nothing (IODataMode mode
forall mode. KnownIODataMode mode => IODataMode mode
IOData.iodataMode :: IODataMode mode)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
errors
  mode -> IO mode
forall (m :: * -> *) a. Monad m => a -> m a
return mode
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 :: KnownIODataMode mode
                  => Verbosity
                  -> FilePath                 -- ^ Program location
                  -> [String]                 -- ^ Arguments
                  -> Maybe FilePath           -- ^ New working dir or inherit
                  -> Maybe [(String, String)] -- ^ New environment or inherit
                  -> Maybe IOData             -- ^ input text and binary mode
                  -> IODataMode mode          -- ^ iodata mode, acts as proxy
                  -> IO (mode, String, ExitCode) -- ^ output, errors, exit
rawSystemStdInOut :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, String, ExitCode)
rawSystemStdInOut Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv Maybe IOData
input IODataMode mode
_ = IO (mode, String, ExitCode) -> IO (mode, String, ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (mode, String, ExitCode) -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode) -> IO (mode, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args

  IO (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO ())
-> ((Handle, Handle, Handle, ProcessHandle)
    -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
     (String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv)
     (\(Handle
inh,Handle
outh,Handle
errh,ProcessHandle
_) -> Handle -> IO ()
hClose Handle
inh IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
outh IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
errh)
    (((Handle, Handle, Handle, ProcessHandle)
  -> IO (mode, String, ExitCode))
 -> IO (mode, String, ExitCode))
-> ((Handle, Handle, Handle, ProcessHandle)
    -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ \(Handle
inh,Handle
outh,Handle
errh,ProcessHandle
pid) -> do

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

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

      IO String
-> (AsyncM String -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b. NFData a => IO a -> (AsyncM a -> IO b) -> IO b
withAsyncNF (Handle -> IO String
hGetContents Handle
errh) ((AsyncM String -> IO (mode, String, ExitCode))
 -> IO (mode, String, ExitCode))
-> (AsyncM String -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ \AsyncM String
errA -> IO mode
-> (AsyncM mode -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b. NFData a => IO a -> (AsyncM a -> IO b) -> IO b
withAsyncNF (Handle -> IO mode
forall mode. KnownIODataMode mode => Handle -> IO mode
IOData.hGetIODataContents Handle
outh) ((AsyncM mode -> IO (mode, String, ExitCode))
 -> IO (mode, String, ExitCode))
-> (AsyncM mode -> IO (mode, String, ExitCode))
-> IO (mode, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ \AsyncM mode
outA -> do
        -- push all the input, if any
        IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Maybe IOData
input of
          Maybe IOData
Nothing        -> Handle -> IO ()
hClose Handle
inh
          Just IOData
inputData -> Handle -> IOData -> IO ()
IOData.hPutContents Handle
inh IOData
inputData

        -- wait for both to finish
        Either SomeException mode
mberr1 <- AsyncM mode -> IO (Either SomeException mode)
forall a. AsyncM a -> IO (Either SomeException a)
waitCatch AsyncM mode
outA
        Either SomeException String
mberr2 <- AsyncM String -> IO (Either SomeException String)
forall a. AsyncM a -> IO (Either SomeException a)
waitCatch AsyncM String
errA

        -- wait for the program to terminate
        ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

        -- get the stderr, so it can be added to error message
        String
err <- Either SomeException String -> IO String
forall a. Either SomeException a -> NoCallStackIO a
reportOutputIOError Either SomeException String
mberr2

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
err then String
"" else
                            String
" with error message:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ case Maybe IOData
input of
                              Maybe IOData
Nothing       -> String
""
                              Just IOData
d | IOData -> Bool
IOData.null IOData
d  -> String
""
                              Just (IODataText String
inp)   -> String
"\nstdin input:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inp
                              Just (IODataBinary ByteString
inp) -> String
"\nstdin input (binary):\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
inp

        -- Check if we we hit an exception while consuming the output
        -- (e.g. a text decoding error)
        mode
out <- Either SomeException mode -> IO mode
forall a. Either SomeException a -> NoCallStackIO a
reportOutputIOError Either SomeException mode
mberr1

        (mode, String, ExitCode) -> IO (mode, String, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (mode
out, String
err, ExitCode
exitcode)
  where
    reportOutputIOError :: Either Exception.SomeException a -> NoCallStackIO a
    reportOutputIOError :: Either SomeException a -> NoCallStackIO a
reportOutputIOError (Right a
x) = a -> NoCallStackIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    reportOutputIOError (Left SomeException
exc) = case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
        Just IOError
ioe -> IOError -> NoCallStackIO a
forall e a. Exception e => e -> IO a
throwIO (IOError -> String -> IOError
ioeSetFileName IOError
ioe (String
"output of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path))
        Maybe IOError
Nothing  -> SomeException -> NoCallStackIO a
forall e a. Exception e => e -> IO a
throwIO SomeException
exc

    ignoreSigPipe :: NoCallStackIO () -> NoCallStackIO ()
    ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle ((IOError -> IO ()) -> IO () -> IO ())
-> (IOError -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOError
e -> case IOError
e of
        GHC.IOError { ioe_type :: IOError -> IOErrorType
GHC.ioe_type  = IOErrorType
GHC.ResourceVanished, ioe_errno :: IOError -> Maybe CInt
GHC.ioe_errno = Just CInt
ioe }
            | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IOError
_ -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e

-- | 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 :: String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion String
versionArg String -> String
selectVersion Verbosity
verbosity String
path = IO (Maybe Version) -> IO (Maybe Version)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
  String
str <- Verbosity -> String -> [String] -> IO String
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity String
path [String
versionArg]
         IO String -> (IOError -> IO String) -> IO String
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO`   (\IOError
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")
         IO String -> (ExitCode -> IO String) -> IO String
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")
  let version :: Maybe Version
      version :: Maybe Version
version = String -> Maybe Version
forall a. Parsec a => String -> Maybe a
simpleParsec (String -> String
selectVersion String
str)
  case Maybe Version
version of
      Maybe Version
Nothing -> Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"cannot determine version of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str
      Just Version
v  -> Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
v
  Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
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 :: Int -> ([String] -> IO ()) -> [String] -> [String] -> IO ()
xargs Int
maxSize [String] -> IO ()
rawSystemFun [String]
fixedArgs [String]
bigArgs =
  let fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fixedArgs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fixedArgs
      chunkSize :: Int
chunkSize = Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize
   in ([String] -> IO ()) -> [[String]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([String] -> IO ()
[String] -> IO ()
rawSystemFun ([String] -> IO ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
fixedArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)) (Int -> [String] -> [[String]]
forall (t :: * -> *) a. Foldable t => Int -> [t a] -> [[t a]]
chunks Int
chunkSize [String]
bigArgs)

  where chunks :: Int -> [t a] -> [[t a]]
chunks Int
len = ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]])
-> ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall a b. (a -> b) -> a -> b
$ \[t a]
s ->
          if [t a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t a]
s then Maybe ([t a], [t a])
forall a. Maybe a
Nothing
                    else ([t a], [t a]) -> Maybe ([t a], [t a])
forall a. a -> Maybe a
Just ([t a] -> Int -> [t a] -> ([t a], [t a])
forall (t :: * -> *) a.
Foldable t =>
[t a] -> Int -> [t a] -> ([t a], [t a])
chunk [] Int
len [t a]
s)

        chunk :: [t a] -> Int -> [t a] -> ([t a], [t a])
chunk [t a]
acc Int
_   []     = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc,[])
        chunk [t a]
acc Int
len (t a
s:[t a]
ss)
          | Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = [t a] -> Int -> [t a] -> ([t a], [t a])
chunk (t a
st a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
acc) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [t a]
ss
          | Bool
otherwise  = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc, t a
st a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
ss)
          where len' :: Int
len' = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
s

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

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


{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findFile :: [FilePath]    -- ^search locations
         -> FilePath      -- ^File Name
         -> IO FilePath
findFile :: [String] -> String -> IO String
findFile = Verbosity -> [String] -> String -> IO String
findFileEx Verbosity
normal

-- | Find a file by looking in a search path. The file path must match exactly.
--
findFileEx :: Verbosity
           -> [FilePath]    -- ^search locations
           -> FilePath      -- ^File Name
           -> IO FilePath
findFileEx :: Verbosity -> [String] -> String -> IO String
findFileEx Verbosity
verbosity [String]
searchPath String
fileName =
  (String -> String) -> [String] -> NoCallStackIO (Maybe String)
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile String -> String
forall a. a -> a
id
    [ String
path String -> String -> String
</> String
fileName
    | String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath]
  NoCallStackIO (Maybe String)
-> (Maybe String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
fileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" doesn't exist") String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
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 :: [String] -> [String] -> String -> NoCallStackIO (Maybe String)
findFileWithExtension [String]
extensions [String]
searchPath String
baseName =
  (String -> String) -> [String] -> NoCallStackIO (Maybe String)
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile String -> String
forall a. a -> a
id
    [ String
path String -> String -> String
</> String
baseName String -> String -> String
<.> String
ext
    | String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
    , String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
extensions ]

findAllFilesWithExtension :: [String]
                          -> [FilePath]
                          -> FilePath
                          -> NoCallStackIO [FilePath]
findAllFilesWithExtension :: [String] -> [String] -> String -> NoCallStackIO [String]
findAllFilesWithExtension [String]
extensions [String]
searchPath String
basename =
  (String -> String) -> [String] -> NoCallStackIO [String]
forall a. (a -> String) -> [a] -> NoCallStackIO [a]
findAllFiles String -> String
forall a. a -> a
id
    [ String
path String -> String -> String
</> String
basename String -> String -> String
<.> String
ext
    | String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
    , String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
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' :: [String]
-> [String] -> String -> NoCallStackIO (Maybe (String, String))
findFileWithExtension' [String]
extensions [String]
searchPath String
baseName =
  ((String, String) -> String)
-> [(String, String)] -> NoCallStackIO (Maybe (String, String))
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile ((String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
(</>))
    [ (String
path, String
baseName String -> String -> String
<.> String
ext)
    | String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
    , String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
extensions ]

findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile :: (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile a -> String
file = [a] -> NoCallStackIO (Maybe a)
findFirst
  where findFirst :: [a] -> NoCallStackIO (Maybe a)
findFirst []     = Maybe a -> NoCallStackIO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        findFirst (a
x:[a]
xs) = do Bool
exists <- String -> IO Bool
doesFileExist (a -> String
file a
x)
                              if Bool
exists
                                then Maybe a -> NoCallStackIO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
                                else [a] -> NoCallStackIO (Maybe a)
findFirst [a]
xs

findAllFiles :: (a -> FilePath) -> [a] -> NoCallStackIO [a]
findAllFiles :: (a -> String) -> [a] -> NoCallStackIO [a]
findAllFiles a -> String
file = (a -> IO Bool) -> [a] -> NoCallStackIO [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> (a -> String) -> a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
file)


{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findModuleFiles :: [FilePath]   -- ^ build prefix (location of objects)
                -> [String]     -- ^ search suffixes
                -> [ModuleName] -- ^ modules
                -> IO [(FilePath, FilePath)]
findModuleFiles :: [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFiles = Verbosity
-> [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFilesEx Verbosity
normal

-- | Finds the files corresponding to a list of Haskell module names.
--
-- As 'findModuleFile' but for a list of module names.
--
findModuleFilesEx :: Verbosity
                  -> [FilePath]   -- ^ build prefix (location of objects)
                  -> [String]     -- ^ search suffixes
                  -> [ModuleName] -- ^ modules
                  -> IO [(FilePath, FilePath)]
findModuleFilesEx :: Verbosity
-> [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFilesEx Verbosity
verbosity [String]
searchPath [String]
extensions [ModuleName]
moduleNames =
  (ModuleName -> IO (String, String))
-> [ModuleName] -> IO [(String, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx Verbosity
verbosity [String]
searchPath [String]
extensions) [ModuleName]
moduleNames

{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)
               -> [String]    -- ^ search suffixes
               -> ModuleName  -- ^ module
               -> IO (FilePath, FilePath)
findModuleFile :: [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFile = Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx Verbosity
normal

-- | 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.
--
findModuleFileEx :: Verbosity
                 -> [FilePath]  -- ^ build prefix (location of objects)
                 -> [String]    -- ^ search suffixes
                 -> ModuleName  -- ^ module
                 -> IO (FilePath, FilePath)
findModuleFileEx :: Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx Verbosity
verbosity [String]
searchPath [String]
extensions ModuleName
mod_name =
      IO (String, String)
-> ((String, String) -> IO (String, String))
-> Maybe (String, String)
-> IO (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (String, String)
notFound (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return
  (Maybe (String, String) -> IO (String, String))
-> NoCallStackIO (Maybe (String, String)) -> IO (String, String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String]
-> [String] -> String -> NoCallStackIO (Maybe (String, String))
findFileWithExtension' [String]
extensions [String]
searchPath
                             (ModuleName -> String
ModuleName.toFilePath ModuleName
mod_name)
  where
    notFound :: IO (String, String)
notFound = Verbosity -> String -> IO (String, String)
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO (String, String)) -> String -> IO (String, String)
forall a b. (a -> b) -> a -> b
$
      String
"Error: Could not find module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
mod_name
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with any suffix: "          String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
extensions
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in the search path: "       String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
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 :: String -> IO [String]
getDirectoryContentsRecursive String
topdir = [String] -> IO [String]
recurseDirectories [String
""]
  where
    recurseDirectories :: [FilePath] -> IO [FilePath]
    recurseDirectories :: [String] -> IO [String]
recurseDirectories []         = [String] -> NoCallStackIO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    recurseDirectories (String
dir:[String]
dirs) = NoCallStackIO [String] -> NoCallStackIO [String]
forall a. IO a -> IO a
unsafeInterleaveIO (NoCallStackIO [String] -> NoCallStackIO [String])
-> NoCallStackIO [String] -> NoCallStackIO [String]
forall a b. (a -> b) -> a -> b
$ do
      ([String]
files, [String]
dirs') <- [String] -> [String] -> [String] -> IO ([String], [String])
collect [] [] ([String] -> IO ([String], [String]))
-> NoCallStackIO [String] -> IO ([String], [String])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> NoCallStackIO [String]
getDirectoryContents (String
topdir String -> String -> String
</> String
dir)
      [String]
files' <- [String] -> IO [String]
recurseDirectories ([String]
dirs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
dirs)
      [String] -> NoCallStackIO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
files')

      where
        collect :: [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files [String]
dirs' []              = ([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
files
                                                     ,[String] -> [String]
forall a. [a] -> [a]
reverse [String]
dirs')
        collect [String]
files [String]
dirs' (String
entry:[String]
entries) | String -> Bool
ignore String
entry
                                            = [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files [String]
dirs' [String]
entries
        collect [String]
files [String]
dirs' (String
entry:[String]
entries) = do
          let dirEntry :: String
dirEntry = String
dir String -> String -> String
</> String
entry
          Bool
isDirectory <- String -> IO Bool
doesDirectoryExist (String
topdir String -> String -> String
</> String
dirEntry)
          if Bool
isDirectory
            then [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
dirs') [String]
entries
            else [String] -> [String] -> [String] -> IO ([String], [String])
collect (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
files) [String]
dirs' [String]
entries

        ignore :: String -> Bool
ignore [Char
'.']      = Bool
True
        ignore [Char
'.', Char
'.'] = Bool
True
        ignore String
_          = Bool
False

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

-- | Is this directory in the system search path?
isInSearchPath :: FilePath -> NoCallStackIO Bool
isInSearchPath :: String -> IO Bool
isInSearchPath String
path = ([String] -> Bool) -> NoCallStackIO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
path) NoCallStackIO [String]
getSearchPath

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

    addEnv :: [(String, String)] -> [(String, String)]
addEnv [] = [(String
ldPath,String
pathsString)]
    addEnv ((String
key,String
value):[(String, String)]
xs)
      | String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ldPath =
          if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
value
             then (String
key,String
pathsString)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
xs
             else (String
key,String
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
searchPathSeparatorChar -> String -> String
forall a. a -> [a] -> [a]
:String
pathsString))(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
xs
      | Bool
otherwise     = (String
key,String
value)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)] -> [(String, String)]
addEnv [(String, String)]
xs

--------------------
-- 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 :: String -> String -> IO Bool
moreRecentFile String
a String
b = do
  Bool
exists <- String -> IO Bool
doesFileExist String
b
  if Bool -> Bool
not Bool
exists
    then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do UTCTime
tb <- String -> IO UTCTime
getModificationTime String
b
            UTCTime
ta <- String -> IO UTCTime
getModificationTime String
a
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
ta UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
tb)

-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> NoCallStackIO Bool
existsAndIsMoreRecentThan :: String -> String -> IO Bool
existsAndIsMoreRecentThan String
a String
b = do
  Bool
exists <- String -> IO Bool
doesFileExist String
a
  if Bool -> Bool
not Bool
exists
    then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else String
a String -> String -> IO Bool
`moreRecentFile` String
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 -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
create_parents String
path0
  | Bool
create_parents = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
createDirs (String -> [String]
parents String
path0)
  | Bool
otherwise      = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
createDirs (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 (String -> [String]
parents String
path0))
  where
    parents :: String -> [String]
parents = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> [String] -> [String]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 String -> String -> String
(</>) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise

    createDirs :: [String] -> IO ()
createDirs []         = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    createDirs (String
dir:[])   = String -> (IOError -> IO ()) -> IO ()
createDir String
dir IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO
    createDirs (String
dir:[String]
dirs) =
      String -> (IOError -> IO ()) -> IO ()
createDir String
dir ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOError
_ -> do
        [String] -> IO ()
createDirs [String]
dirs
        String -> (IOError -> IO ()) -> IO ()
createDir String
dir IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO

    createDir :: FilePath -> (IOException -> IO ()) -> IO ()
    createDir :: String -> (IOError -> IO ()) -> IO ()
createDir String
dir IOError -> IO ()
notExistHandler = do
      Either IOError ()
r <- IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
tryIO (IO () -> IO (Either IOError ()))
-> IO () -> IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
createDirectoryVerbose Verbosity
verbosity String
dir
      case (Either IOError ()
r :: Either IOException ()) of
        Right ()                   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left  IOError
e
          | IOError -> Bool
isDoesNotExistError  IOError
e -> IOError -> IO ()
notExistHandler IOError
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.
          | IOError -> Bool
isAlreadyExistsError IOError
e -> (do
              Bool
isDir <- String -> IO Bool
doesDirectoryExist String
dir
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
              ) IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` ((\IOError
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) :: IOException -> IO ())
          | Bool
otherwise              -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e

createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
createDirectoryVerbose :: Verbosity -> String -> IO ()
createDirectoryVerbose Verbosity
verbosity String
dir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
  String -> IO ()
createDirectory String
dir
  String -> IO ()
setDirOrdinary String
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 -> String -> String -> IO ()
copyFileVerbose Verbosity
verbosity String
src String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"copy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
  String -> String -> IO ()
copyFile String
src String
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 -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
src String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Installing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
  String -> String -> IO ()
copyOrdinaryFile String
src String
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 -> String -> String -> IO ()
installExecutableFile Verbosity
verbosity String
src String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"Installing executable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
  String -> String -> IO ()
copyExecutableFile String
src String
dest

-- | Install a file that may or not be executable, preserving permissions.
installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installMaybeExecutableFile :: Verbosity -> String -> String -> IO ()
installMaybeExecutableFile Verbosity
verbosity String
src String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Permissions
perms <- String -> IO Permissions
getPermissions String
src
  if (Permissions -> Bool
executable Permissions
perms) --only checks user x bit
    then Verbosity -> String -> String -> IO ()
installExecutableFile Verbosity
verbosity String
src String
dest
    else Verbosity -> String -> String -> IO ()
installOrdinaryFile   Verbosity
verbosity String
src String
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 -> String -> String -> IO ()
copyFileTo Verbosity
verbosity String
dir String
file = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let targetFile :: String
targetFile = String
dir String -> String -> String
</> String
file
  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (String -> String
takeDirectory String
targetFile)
  Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
file String
targetFile

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

  -- Create parent directories for everything
  let dirs :: [String]
dirs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
targetDir String -> String -> String
</>) ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
takeDirectory (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
srcFiles
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True) [String]
dirs

  -- Copy all the files
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: String
src  = String
srcBase   String -> String -> String
</> String
srcFile
                  dest :: String
dest = String
targetDir String -> String -> String
</> String
srcFile
               in Verbosity -> String -> String -> IO ()
doCopy Verbosity
verbosity String
src String
dest
            | (String
srcBase, String
srcFile) <- [(String, String)]
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 :: Verbosity -> String -> [(String, String)] -> IO ()
copyFiles Verbosity
v String
fp [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
v String
fp [(String, String)]
fs)

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

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

-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.
--
installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
                               -> IO ()
installMaybeExecutableFiles :: Verbosity -> String -> [(String, String)] -> IO ()
installMaybeExecutableFiles Verbosity
v String
fp [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
installMaybeExecutableFile Verbosity
v String
fp [(String, String)]
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 -> String -> String -> IO ()
installDirectoryContents Verbosity
verbosity String
srcDir String
destDir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"copy directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' to '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'.")
  [String]
srcFiles <- String -> IO [String]
getDirectoryContentsRecursive String
srcDir
  Verbosity -> String -> [(String, String)] -> IO ()
installOrdinaryFiles Verbosity
verbosity String
destDir [ (String
srcDir, String
f) | String
f <- [String]
srcFiles ]

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

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

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

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

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

defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions = TempFileOptions :: Bool -> TempFileOptions
TempFileOptions { optKeepTempFiles :: Bool
optKeepTempFiles = Bool
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 :: String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile String
tmpDir String
template String -> Handle -> IO a
action =
  TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
forall a.
TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
defaultTempFileOptions String
tmpDir String
template String -> Handle -> IO a
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 :: TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
opts String
tmpDir String
template String -> Handle -> IO a
action =
  IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    (String -> String -> IO (String, Handle)
openTempFile String
tmpDir String
template)
    (\(String
name, Handle
handle) -> do Handle -> IO ()
hClose Handle
handle
                           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TempFileOptions -> Bool
optKeepTempFiles TempFileOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                             () -> IO () -> IO ()
forall a. a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist () (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name)
    (((String, Handle) -> IO a)
-> WithCallStack ((String, Handle) -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack ((String -> Handle -> IO a) -> (String, Handle) -> IO a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Handle -> IO a
String -> Handle -> IO a
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 -> String -> String -> (String -> IO a) -> IO a
withTempDirectory Verbosity
verbosity String
targetDir String
template String -> IO a
f = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
  Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
forall a.
Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
defaultTempFileOptions String
targetDir String
template
    ((String -> IO a) -> WithCallStack (String -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack String -> IO a
f)

-- | A version of 'withTempDirectory' that additionally takes a
-- 'TempFileOptions' argument.
withTempDirectoryEx :: Verbosity -> TempFileOptions
                       -> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectoryEx :: Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx Verbosity
_verbosity TempFileOptions
opts String
targetDir String
template String -> IO a
f = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
  IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    (String -> String -> IO String
createTempDirectory String
targetDir String
template)
    (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TempFileOptions -> Bool
optKeepTempFiles TempFileOptions
opts)
     (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> IO () -> IO ()
forall a. a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist () (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectoryRecursive)
    ((String -> IO a) -> WithCallStack (String -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack String -> IO a
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: Before Cabal-3.0 the file content was assumed to be
--     ASCII-representable. Since Cabal-3.0 the file is assumed to be
--     UTF-8 encoded.
rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()
rewriteFileEx :: Verbosity -> String -> String -> IO ()
rewriteFileEx Verbosity
verbosity String
path String
newContent =
  (IO () -> (IOError -> IO ()) -> IO ())
-> (IOError -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catchIO IOError -> IO ()
mightNotExist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
existingContent <- Verbosity -> IO ByteString -> IO ByteString
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
path
    Int64
_ <- Int64 -> IO Int64
forall a. a -> IO a
evaluate (ByteString -> Int64
BS.length ByteString
existingContent)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
existingContent ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
newContent') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> IO () -> IO ()
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
writeFileAtomic String
path ByteString
newContent'
  where
    newContent' :: ByteString
newContent' = String -> ByteString
toUTF8LBS String
newContent

    mightNotExist :: IOError -> IO ()
mightNotExist IOError
e | IOError -> Bool
isDoesNotExistError IOError
e
                    = Verbosity -> IO () -> IO ()
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
writeFileAtomic String
path ByteString
newContent'
                    | Bool
otherwise
                    = IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e

-- | 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 :: String
currentDir = String
"."

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

-- | Drop the extension if it's one of 'exeExtensions', or return the path
-- unchanged.
dropExeExtension :: FilePath -> FilePath
dropExeExtension :: String -> String
dropExeExtension String
filepath =
  -- System.FilePath's extension handling functions are horribly
  -- inconsistent, consider:
  --
  --     isExtensionOf "" "foo"  == False but
  --     isExtensionOf "" "foo." == True.
  --
  -- On the other hand stripExtension doesn't remove the empty extension:
  --
  --    stripExtension "" "foo." == Just "foo."
  --
  -- Since by "" in exeExtensions we mean 'no extension' anyways we can
  -- just always ignore it here.
  let exts :: [String]
exts = [ String
ext | String
ext <- [String]
exeExtensions, String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" ] in
  String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
filepath (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ do
    String
ext <- (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> String -> Bool
`FilePath.isExtensionOf` String
filepath) [String]
exts
    String
ext String -> String -> Maybe String
`FilePath.stripExtension` String
filepath

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

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

-- | Package description file (/pkgname/@.cabal@)
defaultPackageDesc :: Verbosity -> IO FilePath
defaultPackageDesc :: Verbosity -> IO String
defaultPackageDesc Verbosity
verbosity = Verbosity -> String -> IO String
tryFindPackageDesc Verbosity
verbosity String
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 :: String -> NoCallStackIO (Either String String)
findPackageDesc String
dir
 = do [String]
files <- String -> NoCallStackIO [String]
getDirectoryContents String
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:
      [String]
cabalFiles <- (String -> IO Bool) -> [String] -> NoCallStackIO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist
                       [ String
dir String -> String -> String
</> String
file
                       | String
file <- [String]
files
                       , let (String
name, String
ext) = String -> (String, String)
splitExtension String
file
                       , Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name) Bool -> Bool -> Bool
&& String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal" ]
      case [String]
cabalFiles of
        []          -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left  String
noDesc)
        [String
cabalFile] -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. b -> Either a b
Right String
cabalFile)
        [String]
multiple    -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left  (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> String
multiDesc [String]
multiple)

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

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

-- |Like 'findPackageDesc', but calls 'die' in case of error.
tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath
tryFindPackageDesc :: Verbosity -> String -> IO String
tryFindPackageDesc Verbosity
verbosity String
dir =
  (String -> IO String)
-> (String -> IO String) -> Either String String -> IO String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity) String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO String)
-> NoCallStackIO (Either String String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> NoCallStackIO (Either String String)
findPackageDesc String
dir

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

buildInfoExt  :: String
buildInfoExt :: String
buildInfoExt = String
".buildinfo"