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

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

module Distribution.Simple.Utils (
        cabalVersion,

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

        -- * exceptions
        handleDoesNotExist,

        -- * running programs
        rawSystemExit,
        rawSystemExitCode,
        rawSystemExitWithEnv,
        rawSystemStdout,
        rawSystemStdInOut,
        rawSystemIOWithEnv,
        createProcessWithEnv,
        maybeExit,
        xargs,
        findProgramLocation,
        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(..),
        IODataMode(..),

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

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

        -- * File permissions
        doesExecutableExist,
        setFileOrdinary,
        setFileExecutable,

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

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

        -- * environment variables
        isInSearchPath,
        addLibraryPath,

        -- * modification time
        moreRecentFile,
        existsAndIsMoreRecentThan,

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

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

        -- * reading and writing files safely
        withFileContents,
        writeFileAtomic,
        rewriteFile,
        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,
        safeTail,
        unintersperse,
        wrapText,
        wrapLine,

        -- * FilePath stuff
        isAbsoluteOnAnyPlatform,
        isRelativeOnAnyPlatform,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Utils.Generic
import Distribution.Utils.IOData (IOData(..), IODataMode(..))
import qualified Distribution.Utils.IOData as IOData
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Exception
import Distribution.Compat.Stack
import Distribution.Verbosity
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 Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, takeMVar )
import Data.Typeable
    ( cast )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8

import System.Directory
    ( Permissions(executable), getDirectoryContents, getPermissions
    , doesDirectoryExist, doesFileExist, removeFile, findExecutable
    , getModificationTime, createDirectory, removeDirectoryRecursive )
import System.Environment
    ( getProgName )
import System.Exit
    ( exitWith, ExitCode(..) )
import System.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 Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Control.Exception (IOException, evaluate, throwIO)
import Control.Concurrent (forkIO)
import Numeric (showFFloat)
import qualified System.Process as Process
         ( CreateProcess(..), StdStream(..), proc)
import System.Process
         ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
         , showCommandForUser, waitForProcess)

import qualified Text.PrettyPrint as Disp

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

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

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

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

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

dieNoVerbosity :: String -> IO a
dieNoVerbosity :: FilePath -> IO a
dieNoVerbosity msg :: FilePath
msg
    = IOError -> IO a
forall a. IOError -> IO a
ioError (FilePath -> IOError
userError FilePath
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 e :: IOError
e = IOError -> FilePath -> IOError
ioeSetLocation IOError
e "dieVerbatim"

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

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

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

die' :: Verbosity -> String -> IO a
die' :: Verbosity -> FilePath -> IO a
die' verbosity :: Verbosity
verbosity msg :: FilePath
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
    FilePath
pname <- IO FilePath
getProgName
    IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (FilePath -> IOError) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
verbatimUserError
            (FilePath -> IOError)
-> (FilePath -> FilePath) -> FilePath -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
            (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> FilePath
wrapTextVerbosity Verbosity
verbosity
            (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
pname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg

dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap :: Verbosity -> FilePath -> IO a
dieNoWrap verbosity :: Verbosity
verbosity msg :: FilePath
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) -> (FilePath -> IOError) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
verbatimUserError
            (FilePath -> IOError)
-> (FilePath -> FilePath) -> FilePath -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
            (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
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
verbosity act :: 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 ts :: POSIXTime
ts ioe :: IOError
ioe = IOError -> FilePath -> IOError
ioeSetErrorString IOError
ioe
             (FilePath -> IOError)
-> (FilePath -> FilePath) -> FilePath -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
VerboseTrace Verbosity
verbosity
             (FilePath -> IOError) -> FilePath -> IOError
forall a b. (a -> b) -> a -> b
$ IOError -> FilePath
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 cont :: SomeException -> IO a
cont prog :: 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 a :: 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 se :: SomeException
se = do
      Handle -> IO ()
hFlush Handle
stdout
      FilePath
pname <- IO FilePath
getProgName
      Handle -> FilePath -> IO ()
hPutStr Handle
stderr (FilePath -> SomeException -> FilePath
message FilePath
pname SomeException
se)
      SomeException -> IO a
cont SomeException
se

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

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

topHandler :: IO a -> IO a
topHandler :: IO a -> IO a
topHandler prog :: 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 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 -> FilePath -> IO ()
warn verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stderr (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> FilePath
wrapTextVerbosity Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Warning: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 -> FilePath -> IO ()
notice verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> FilePath
wrapTextVerbosity Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
msg

-- | Display a message at 'normal' verbosity level, but without
-- wrapping.
--
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap :: Verbosity -> FilePath -> IO ()
noticeNoWrap verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
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
verbosity msg :: 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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (Doc -> FilePath) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> FilePath) -> (Doc -> FilePath) -> Doc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Doc -> FilePath
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 -> FilePath -> PackageIdentifier -> IO ()
setupMessage verbosity :: Verbosity
verbosity msg :: FilePath
msg pkgid :: PackageIdentifier
pkgid = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> FilePath -> IO ()
noticeNoWrap Verbosity
verbosity (FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ' 'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "...")

-- | More detail on the operation of some action.
--
-- We display these messages when the verbosity level is 'verbose'
--
info :: Verbosity -> String -> IO ()
info :: Verbosity -> FilePath -> IO ()
info verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> FilePath
wrapTextVerbosity Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
msg

infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap :: Verbosity -> FilePath -> IO ()
infoNoWrap verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
msg

-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
--
debug :: Verbosity -> String -> IO ()
debug :: Verbosity -> FilePath -> IO ()
debug verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> FilePath
wrapTextVerbosity Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
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 -> FilePath -> IO ()
debugNoWrap verbosity :: Verbosity
verbosity msg :: FilePath
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 -> FilePath -> IO ()
hPutStr Handle
stdout (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
  (POSIXTime
   -> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath)
POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> FilePath -> FilePath
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
                   (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
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 :: FilePath -> IO () -> IO ()
chattyTry desc :: FilePath
desc action :: 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
$ \exception :: IOError
exception ->
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error while " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
desc FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
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 e :: 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
      (\ioe :: 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)
      (\_ -> 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 -> FilePath -> FilePath
wrapTextVerbosity verb :: Verbosity
verb
  | Verbosity -> Bool
isVerboseNoWrap Verbosity
verb = FilePath -> FilePath
withTrailingNewline
  | Bool
otherwise            = FilePath -> FilePath
withTrailingNewline (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
wrapText


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

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

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

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

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

-- | Prepend a call-site and/or call-stack based on Verbosity
--
withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)
withCallStackPrefix :: TraceWhen -> Verbosity -> FilePath -> FilePath
withCallStackPrefix tracer :: TraceWhen
tracer verbosity :: Verbosity
verbosity s :: FilePath
s = (HasCallStack => FilePath) -> FilePath
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => FilePath) -> FilePath)
-> (HasCallStack => FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$
    (if Verbosity -> Bool
isVerboseCallSite Verbosity
verbosity
        then FilePath
HasCallStack => FilePath
parentSrcLocPrefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             -- Hack: need a newline before starting output marker :(
             if Verbosity -> Bool
isVerboseMarkOutput Verbosity
verbosity
                then "\n"
                else ""
        else "") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    (case Verbosity -> TraceWhen -> Maybe FilePath
traceWhen Verbosity
verbosity TraceWhen
tracer of
        Just pre :: FilePath
pre -> FilePath
pre FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ CallStack -> FilePath
prettyCallStack CallStack
HasCallStack => CallStack
callStack FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n"
        Nothing  -> "") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
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 FilePath
traceWhen _ AlwaysTrace = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ""
traceWhen v :: Verbosity
v VerboseTrace | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose         = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ""
traceWhen v :: Verbosity
v FlagTrace    | Verbosity -> Bool
isVerboseCallStack Verbosity
v = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "----\n"
traceWhen _ _ = Maybe FilePath
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 -> FilePath -> FilePath
withMetadata ts :: POSIXTime
ts marker :: MarkWhen
marker tracer :: TraceWhen
tracer verbosity :: Verbosity
verbosity x :: FilePath
x = (HasCallStack => FilePath) -> FilePath
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => FilePath) -> FilePath)
-> (HasCallStack => FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$
    -- NB: order matters.  Output marker first because we
    -- don't want to capture call stacks.
      FilePath -> FilePath
withTrailingNewline
    (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack (TraceWhen -> Verbosity -> FilePath -> FilePath)
TraceWhen -> Verbosity -> FilePath -> FilePath
withCallStackPrefix TraceWhen
tracer Verbosity
verbosity
    (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case MarkWhen
marker of
        AlwaysMark -> Verbosity -> FilePath -> FilePath
withOutputMarker Verbosity
verbosity
        NormalMark | Bool -> Bool
not (Verbosity -> Bool
isVerboseQuiet Verbosity
verbosity)
                   -> Verbosity -> FilePath -> FilePath
withOutputMarker Verbosity
verbosity
                   | Bool
otherwise
                   -> FilePath -> FilePath
forall a. a -> a
id
        NeverMark  -> FilePath -> FilePath
forall a. a -> a
id)
    -- Clear out any existing markers
    (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
clearMarkers
    (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> POSIXTime -> FilePath -> FilePath
withTimestamp Verbosity
verbosity POSIXTime
ts
    (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
x

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

-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd :: 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 -> FilePath -> [FilePath] -> IO ()
printRawCommandAndArgs verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
args = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity FilePath
path [FilePath]
args Maybe FilePath
forall a. Maybe a
Nothing Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing

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

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

rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
rawSystemExitCode :: Verbosity -> FilePath -> [FilePath] -> IO ExitCode
rawSystemExitCode verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
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 -> FilePath -> [FilePath] -> IO ()
printRawCommandAndArgs Verbosity
verbosity FilePath
path [FilePath]
args
  Handle -> IO ()
hFlush Handle
stdout
  ExitCode
exitcode <- FilePath -> [FilePath] -> IO ExitCode
rawSystem FilePath
path [FilePath]
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 -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " returned " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
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
-> FilePath -> [FilePath] -> [(FilePath, FilePath)] -> IO ()
rawSystemExitWithEnv verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
args env :: [(FilePath, FilePath)]
env = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity FilePath
path [FilePath]
args Maybe FilePath
forall a. Maybe a
Nothing ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
env)
    Handle -> IO ()
hFlush Handle
stdout
    (_,_,_,ph :: 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
$
                  (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
path [FilePath]
args) { env :: Maybe [(FilePath, FilePath)]
Process.env = ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
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 -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " returned " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
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
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
args mcwd :: Maybe FilePath
mcwd menv :: Maybe [(FilePath, FilePath)]
menv inp :: Maybe Handle
inp out :: Maybe Handle
out err :: 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
    (_,_,_,ph :: ProcessHandle
ph) <- Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity FilePath
path [FilePath]
args Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
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 -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " returned " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
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
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
args mcwd :: Maybe FilePath
mcwd menv :: Maybe [(FilePath, FilePath)]
menv inp :: StdStream
inp out :: StdStream
out err :: 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
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity FilePath
path [FilePath]
args Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
menv
    Handle -> IO ()
hFlush Handle
stdout
    (inp' :: Maybe Handle
inp', out' :: Maybe Handle
out', err' :: Maybe Handle
err', ph :: 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
$
                                (FilePath -> [FilePath] -> CreateProcess
Process.proc FilePath
path [FilePath]
args) {
                                    cwd :: Maybe FilePath
Process.cwd           = Maybe FilePath
mcwd
                                  , env :: Maybe [(FilePath, FilePath)]
Process.env           = Maybe [(FilePath, FilePath)]
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 :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout :: Verbosity -> FilePath -> [FilePath] -> IO FilePath
rawSystemStdout verbosity :: Verbosity
verbosity path :: FilePath
path args :: [FilePath]
args = IO FilePath -> IO FilePath
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ do
  (IODataText output :: FilePath
output, errors :: FilePath
errors, exitCode :: ExitCode
exitCode) <- Verbosity
-> FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, FilePath, ExitCode)
rawSystemStdInOut Verbosity
verbosity FilePath
path [FilePath]
args
                                                  Maybe FilePath
forall a. Maybe a
Nothing Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
                                                  Maybe IOData
forall a. Maybe a
Nothing IODataMode
IODataModeText
  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
$
    FilePath -> IO ()
forall a. FilePath -> IO a
die FilePath
errors
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output

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

  IO (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO ())
-> ((Handle, Handle, Handle, ProcessHandle)
    -> IO (IOData, FilePath, ExitCode))
-> IO (IOData, FilePath, ExitCode)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
     (FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess FilePath
path [FilePath]
args Maybe FilePath
mcwd Maybe [(FilePath, FilePath)]
menv)
     (\(inh :: Handle
inh,outh :: Handle
outh,errh :: Handle
errh,_) -> 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 (IOData, FilePath, ExitCode))
 -> IO (IOData, FilePath, ExitCode))
-> ((Handle, Handle, Handle, ProcessHandle)
    -> IO (IOData, FilePath, ExitCode))
-> IO (IOData, FilePath, ExitCode)
forall a b. (a -> b) -> a -> b
$ \(inh :: Handle
inh,outh :: Handle
outh,errh :: Handle
errh,pid :: 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.

      FilePath
err <- Handle -> IO FilePath
hGetContents Handle
errh

      IOData
out <- Handle -> IODataMode -> IO IOData
IOData.hGetContents Handle
outh IODataMode
outputMode

      MVar (Either IOError ())
mv <- IO (MVar (Either IOError ()))
forall a. IO (MVar a)
newEmptyMVar
      let force :: a -> IO ()
force str :: a
str = do
            Either IOError ()
mberr <- IO () -> IO (Either IOError ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (() -> IO ()
forall a. a -> IO a
evaluate (a -> ()
forall a. NFData a => a -> ()
rnf a
str) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            MVar (Either IOError ()) -> Either IOError () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either IOError ())
mv (Either IOError ()
mberr :: Either IOError ())
      ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IOData -> IO ()
forall a. NFData a => a -> IO ()
force IOData
out
      ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. NFData a => a -> IO ()
force FilePath
err

      -- push all the input, if any
      case Maybe IOData
input of
        Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just inputData :: IOData
inputData -> do
          -- input mode depends on what the caller wants
          Handle -> IOData -> IO ()
IOData.hPutContents Handle
inh IOData
inputData
          --TODO: this probably fails if the process refuses to consume
          -- or if it closes stdin (eg if it exits)

      -- wait for both to finish, in either order
      Either IOError ()
mberr1 <- MVar (Either IOError ()) -> IO (Either IOError ())
forall a. MVar a -> IO a
takeMVar MVar (Either IOError ())
mv
      Either IOError ()
mberr2 <- MVar (Either IOError ()) -> IO (Either IOError ())
forall a. MVar a -> IO a
takeMVar MVar (Either IOError ())
mv

      -- wait for the program to terminate
      ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
      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 -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " returned " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
exitcode
                       FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
err then "" else
                          " with error message:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
                       FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ case Maybe IOData
input of
                            Nothing       -> ""
                            Just d :: IOData
d | IOData -> Bool
IOData.null IOData
d -> ""
                            Just (IODataText inp :: FilePath
inp) -> "\nstdin input:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
inp
                            Just (IODataBinary inp :: ByteString
inp) -> "\nstdin input (binary):\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
inp

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

      (IOData, FilePath, ExitCode) -> IO (IOData, FilePath, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (IOData
out, FilePath
err, ExitCode
exitcode)
  where
    reportOutputIOError :: Either IOError () -> NoCallStackIO ()
    reportOutputIOError :: Either IOError () -> IO ()
reportOutputIOError =
      (IOError -> IO ()) -> (() -> IO ()) -> Either IOError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\e :: IOError
e -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOError -> FilePath -> IOError
ioeSetFileName IOError
e ("output of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path)))
             () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return


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


-- | Look for a program and try to find it's version number. It can accept
-- either an absolute path or the name of a program binary, in which case we
-- will look for the program on the path.
--
findProgramVersion :: String             -- ^ version args
                   -> (String -> String) -- ^ function to select version
                                         --   number from program output
                   -> Verbosity
                   -> FilePath           -- ^ location
                   -> IO (Maybe Version)
findProgramVersion :: FilePath
-> (FilePath -> FilePath)
-> Verbosity
-> FilePath
-> IO (Maybe Version)
findProgramVersion versionArg :: FilePath
versionArg selectVersion :: FilePath -> FilePath
selectVersion verbosity :: Verbosity
verbosity path :: FilePath
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
  FilePath
str <- Verbosity -> FilePath -> [FilePath] -> IO FilePath
rawSystemStdout Verbosity
verbosity FilePath
path [FilePath
versionArg]
         IO FilePath -> (IOError -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO`   (\_ -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return "")
         IO FilePath -> (ExitCode -> IO FilePath) -> IO FilePath
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\_ -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return "")
  let version :: Maybe Version
      version :: Maybe Version
version = FilePath -> Maybe Version
forall a. Parsec a => FilePath -> Maybe a
simpleParsec (FilePath -> FilePath
selectVersion FilePath
str)
  case Maybe Version
version of
      Nothing -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "cannot determine version of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
                               FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " :\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
str
      Just v :: Version
v  -> Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " is version " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
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 -> ([FilePath] -> IO ()) -> [FilePath] -> [FilePath] -> IO ()
xargs maxSize :: Int
maxSize rawSystemFun :: [FilePath] -> IO ()
rawSystemFun fixedArgs :: [FilePath]
fixedArgs bigArgs :: [FilePath]
bigArgs =
  let fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((FilePath -> Int) -> [FilePath] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
fixedArgs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
fixedArgs
      chunkSize :: Int
chunkSize = Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize
   in ([FilePath] -> IO ()) -> [[FilePath]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([FilePath] -> IO ()
[FilePath] -> IO ()
rawSystemFun ([FilePath] -> IO ())
-> ([FilePath] -> [FilePath]) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath]
fixedArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++)) (Int -> [FilePath] -> [[FilePath]]
forall (t :: * -> *) a. Foldable t => Int -> [t a] -> [[t a]]
chunks Int
chunkSize [FilePath]
bigArgs)

  where chunks :: Int -> [t a] -> [[t a]]
chunks len :: 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
$ \s :: [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 acc :: [t a]
acc _   []     = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc,[])
        chunk acc :: [t a]
acc len :: Int
len (s :: t a
s:ss :: [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
-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

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

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

findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile file :: a -> FilePath
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 (x :: a
x:xs :: [a]
xs) = do Bool
exists <- FilePath -> IO Bool
doesFileExist (a -> FilePath
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 -> FilePath) -> [a] -> NoCallStackIO [a]
findAllFiles file :: a -> FilePath
file = (a -> IO Bool) -> [a] -> NoCallStackIO [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> (a -> FilePath) -> a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
file)

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

-- | Find the file corresponding to a Haskell module name.
--
-- This is similar to 'findFileWithExtension'' but specialised to a module
-- name. The function fails if the file corresponding to the module is missing.
--
findModuleFile :: [FilePath]  -- ^ build prefix (location of objects)
               -> [String]    -- ^ search suffixes
               -> ModuleName  -- ^ module
               -> IO (FilePath, FilePath)
findModuleFile :: [FilePath] -> [FilePath] -> ModuleName -> IO (FilePath, FilePath)
findModuleFile searchPath :: [FilePath]
searchPath extensions :: [FilePath]
extensions mod_name :: ModuleName
mod_name =
      IO (FilePath, FilePath)
-> ((FilePath, FilePath) -> IO (FilePath, FilePath))
-> Maybe (FilePath, FilePath)
-> IO (FilePath, FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (FilePath, FilePath)
forall a. IO a
notFound (FilePath, FilePath) -> IO (FilePath, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return
  (Maybe (FilePath, FilePath) -> IO (FilePath, FilePath))
-> NoCallStackIO (Maybe (FilePath, FilePath))
-> IO (FilePath, FilePath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [FilePath]
-> [FilePath]
-> FilePath
-> NoCallStackIO (Maybe (FilePath, FilePath))
findFileWithExtension' [FilePath]
extensions [FilePath]
searchPath
                             (ModuleName -> FilePath
ModuleName.toFilePath ModuleName
mod_name)
  where
    notFound :: IO a
notFound = FilePath -> IO a
forall a. FilePath -> IO a
die (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ "Error: Could not find module: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ModuleName
mod_name
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " with any suffix: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
extensions
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " in the search path: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
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 :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir :: FilePath
topdir = [FilePath] -> IO [FilePath]
recurseDirectories [""]
  where
    recurseDirectories :: [FilePath] -> IO [FilePath]
    recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories []         = [FilePath] -> NoCallStackIO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    recurseDirectories (dir :: FilePath
dir:dirs :: [FilePath]
dirs) = NoCallStackIO [FilePath] -> NoCallStackIO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (NoCallStackIO [FilePath] -> NoCallStackIO [FilePath])
-> NoCallStackIO [FilePath] -> NoCallStackIO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
      (files :: [FilePath]
files, dirs' :: [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] [] ([FilePath] -> IO ([FilePath], [FilePath]))
-> NoCallStackIO [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> NoCallStackIO [FilePath]
getDirectoryContents (FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
dir)
      [FilePath]
files' <- [FilePath] -> IO [FilePath]
recurseDirectories ([FilePath]
dirs' [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
      [FilePath] -> NoCallStackIO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
files')

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

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

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

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

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

    addEnv :: [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addEnv [] = [(FilePath
ldPath,FilePath
pathsString)]
    addEnv ((key :: FilePath
key,value :: FilePath
value):xs :: [(FilePath, FilePath)]
xs)
      | FilePath
key FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
ldPath =
          if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
value
             then (FilePath
key,FilePath
pathsString)(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
xs
             else (FilePath
key,FilePath
value FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char
searchPathSeparatorChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
pathsString))(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)]
xs
      | Bool
otherwise     = (FilePath
key,FilePath
value)(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:[(FilePath, FilePath)] -> [(FilePath, FilePath)]
addEnv [(FilePath, FilePath)]
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 :: FilePath -> FilePath -> IO Bool
moreRecentFile a :: FilePath
a b :: FilePath
b = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
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 <- FilePath -> IO UTCTime
getModificationTime FilePath
b
            UTCTime
ta <- FilePath -> IO UTCTime
getModificationTime FilePath
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 :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan a :: FilePath
a b :: FilePath
b = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
a
  if Bool -> Bool
not Bool
exists
    then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else FilePath
a FilePath -> FilePath -> IO Bool
`moreRecentFile` FilePath
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 -> FilePath -> IO ()
createDirectoryIfMissingVerbose verbosity :: Verbosity
verbosity create_parents :: Bool
create_parents path0 :: FilePath
path0
  | Bool
create_parents = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> IO ()
createDirs (FilePath -> [FilePath]
parents FilePath
path0)
  | Bool
otherwise      = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> IO ()
createDirs (Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take 1 (FilePath -> [FilePath]
parents FilePath
path0))
  where
    parents :: FilePath -> [FilePath]
parents = [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 FilePath -> FilePath -> FilePath
(</>) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath])
-> (FilePath -> FilePath) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
normalise

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

    createDir :: FilePath -> (IOException -> IO ()) -> IO ()
    createDir :: FilePath -> (IOError -> IO ()) -> IO ()
createDir dir :: FilePath
dir notExistHandler :: 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 -> FilePath -> IO ()
createDirectoryVerbose Verbosity
verbosity FilePath
dir
      case (Either IOError ()
r :: Either IOException ()) of
        Right ()                   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left  e :: 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 <- FilePath -> IO Bool
doesDirectoryExist FilePath
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` ((\_ -> () -> 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 -> FilePath -> IO ()
createDirectoryVerbose verbosity :: Verbosity
verbosity dir :: FilePath
dir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "creating " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir
  FilePath -> IO ()
createDirectory FilePath
dir
  FilePath -> IO ()
setDirOrdinary FilePath
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 -> FilePath -> FilePath -> IO ()
copyFileVerbose verbosity :: Verbosity
verbosity src :: FilePath
src dest :: FilePath
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity ("copy " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dest)
  FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
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 -> FilePath -> FilePath -> IO ()
installOrdinaryFile verbosity :: Verbosity
verbosity src :: FilePath
src dest :: FilePath
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity ("Installing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dest)
  FilePath -> FilePath -> IO ()
copyOrdinaryFile FilePath
src FilePath
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 -> FilePath -> FilePath -> IO ()
installExecutableFile verbosity :: Verbosity
verbosity src :: FilePath
src dest :: FilePath
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity ("Installing executable " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dest)
  FilePath -> FilePath -> IO ()
copyExecutableFile FilePath
src FilePath
dest

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

-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
-> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith doCopy :: Verbosity -> FilePath -> FilePath -> IO ()
doCopy verbosity :: Verbosity
verbosity targetDir :: FilePath
targetDir srcFiles :: [(FilePath, FilePath)]
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 :: [FilePath]
dirs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
targetDir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([(FilePath, FilePath)] -> [FilePath])
-> [(FilePath, FilePath)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([(FilePath, FilePath)] -> [FilePath])
-> [(FilePath, FilePath)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
takeDirectory (FilePath -> FilePath)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([(FilePath, FilePath)] -> [FilePath])
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)]
srcFiles
  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True) [FilePath]
dirs

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

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

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

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

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

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

-- | Like 'doesFileExist', but also checks that the file is executable.
doesExecutableExist :: FilePath -> NoCallStackIO Bool
doesExecutableExist :: FilePath -> IO Bool
doesExecutableExist f :: FilePath
f = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
f
  if Bool
exists
    then do Permissions
perms <- FilePath -> IO Permissions
getPermissions FilePath
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

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

{-# DEPRECATED smartCopySources
      "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-}
smartCopySources :: Verbosity -> [FilePath] -> FilePath
                 -> [ModuleName] -> [String] -> IO ()
smartCopySources :: Verbosity
-> [FilePath] -> FilePath -> [ModuleName] -> [FilePath] -> IO ()
smartCopySources verbosity :: Verbosity
verbosity searchPath :: [FilePath]
searchPath targetDir :: FilePath
targetDir moduleNames :: [ModuleName]
moduleNames extensions :: [FilePath]
extensions = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [FilePath]
-> [FilePath] -> [ModuleName] -> IO [(FilePath, FilePath)]
findModuleFiles [FilePath]
searchPath [FilePath]
extensions [ModuleName]
moduleNames
  IO [(FilePath, FilePath)]
-> ([(FilePath, FilePath)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFiles Verbosity
verbosity FilePath
targetDir

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

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

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

{-# DEPRECATED rewriteFile "Use rewriteFileEx so that Verbosity is respected" #-}
rewriteFile :: FilePath -> String -> IO ()
rewriteFile :: FilePath -> FilePath -> IO ()
rewriteFile = Verbosity -> FilePath -> FilePath -> IO ()
rewriteFileEx Verbosity
normal

-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
--
-- NB: the file is assumed to be ASCII-encoded.
rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()
rewriteFileEx :: Verbosity -> FilePath -> FilePath -> IO ()
rewriteFileEx verbosity :: Verbosity
verbosity path :: FilePath
path newContent :: FilePath
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
    FilePath
existingContent <- Verbosity -> IO FilePath -> IO FilePath
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
path
    Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
existingContent)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
existingContent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
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
$
        FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
path (FilePath -> ByteString
BS.Char8.pack FilePath
newContent)
  where
    mightNotExist :: IOError -> IO ()
mightNotExist e :: 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
$ FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
path
                        (FilePath -> ByteString
BS.Char8.pack FilePath
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 :: FilePath
currentDir = "."

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

-- | Drop the extension if it's one of 'exeExtensions', or return the path
-- unchanged.
dropExeExtension :: FilePath -> FilePath
dropExeExtension :: FilePath -> FilePath
dropExeExtension filepath :: FilePath
filepath =
  case FilePath -> (FilePath, FilePath)
splitExtension FilePath
filepath of
    (filepath' :: FilePath
filepath', extension :: FilePath
extension) | FilePath
extension FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
exeExtensions -> FilePath
filepath'
                           | Bool
otherwise                      -> FilePath
filepath

-- | List of possible executable file extensions on the current platform.
exeExtensions :: [String]
exeExtensions :: [FilePath]
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".
  Windows -> ["", "exe"]
  Ghcjs   -> ["", "exe"]
  _       -> [""]

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

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

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

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

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

{-# DEPRECATED defaultHookedPackageDesc "Use findHookedPackageDesc with the proper base directory instead" #-}
-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
defaultHookedPackageDesc :: IO (Maybe FilePath)
defaultHookedPackageDesc :: IO (Maybe FilePath)
defaultHookedPackageDesc = FilePath -> IO (Maybe FilePath)
findHookedPackageDesc FilePath
currentDir

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

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