{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
#if MIN_VERSION_base(4,21,0)
{-# LANGUAGE ImplicitParams #-}
#endif
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
#ifdef GIT_REV
{-# LANGUAGE TemplateHaskell #-}
#endif

-----------------------------------------------------------------------------

-- |
-- 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
  , cabalGitInfo
  , cabalCompilerInfo

    -- * logging and errors
  , dieNoVerbosity
  , die'
  , dieWithException
  , dieWithLocation'
  , dieNoWrap
  , topHandler
  , topHandlerWith
  , isUserException
  , warn
  , warnError
  , notice
  , noticeNoWrap
  , noticeDoc
  , setupMessage
  , info
  , infoNoWrap
  , debug
  , debugNoWrap
  , chattyTry
  , annotateIO
  , exceptionWithMetadata
  , withOutputMarker

    -- * exceptions
  , handleDoesNotExist
  , ignoreSigPipe

    -- * running programs
  , rawSystemExit
  , rawSystemExitCode
  , rawSystemProc
  , rawSystemProcAction
  , rawSystemExitWithEnv
  , rawSystemExitWithEnvCwd
  , rawSystemStdout
  , rawSystemStdInOut
  , rawSystemIOWithEnv
  , rawSystemIOWithEnvAndAction
  , fromCreatePipe
  , maybeExit
  , xargs
  , findProgramVersion

    -- ** 'IOData' re-export

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

    -- * copying files
  , createDirectoryIfMissingVerbose
  , copyFileVerbose
  , copyFiles
  , copyFileTo
  , copyFileToCwd

    -- * removing files
  , removeFileForcibly

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

    -- * File permissions
  , doesExecutableExist
  , setFileOrdinary
  , setFileExecutable

    -- * file names
  , shortRelativePath
  , dropExeExtension
  , exeExtensions

    -- * finding files
  , findFileEx
  , findFileCwd
  , findFirstFile
  , Suffix (..)
  , findFileWithExtension
  , findFileCwdWithExtension
  , findFileWithExtension'
  , findFileCwdWithExtension'
  , findAllFilesWithExtension
  , findAllFilesCwdWithExtension
  , findModuleFileEx
  , findModuleFileCwd
  , findModuleFilesEx
  , findModuleFilesCwd
  , getDirectoryContentsRecursive

    -- * environment variables
  , isInSearchPath
  , addLibraryPath

    -- * modification time
  , moreRecentFile
  , existsAndIsMoreRecentThan

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

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

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

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

    -- * BOM
  , ignoreBOM

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

    -- * FilePath stuff
  , isAbsoluteOnAnyPlatform
  , isRelativeOnAnyPlatform
  , exceptionWithCallStackPrefix
  ) where

import Distribution.Compat.Async (waitCatch, withAsyncNF)
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Lens (Lens', over)
import Distribution.Compat.Prelude
import Distribution.Compat.Stack
import Distribution.Compat.SysInfo as SIC
import Distribution.ModuleName as ModuleName
import Distribution.Simple.Errors
import Distribution.Simple.PreProcess.Types
import Distribution.System
import Distribution.Types.PackageId
import Distribution.Utils.Generic
import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..))
import qualified Distribution.Utils.IOData as IOData
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
import Prelude ()

#ifdef CURRENT_PACKAGE_KEY
#define BOOTSTRAPPED_CABAL 1
#endif

#ifdef BOOTSTRAPPED_CABAL
import qualified Paths_Cabal (version)
#endif

import Distribution.Parsec
import Distribution.Pretty

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

import Control.Concurrent (threadDelay)
import qualified Control.Exception as Exception
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import qualified Data.Version as DV
import Distribution.Compat.Process (proc)
import Foreign.C.Error (Errno (..), ePIPE)
import qualified GHC.IO.Exception as GHC
import GHC.Stack (HasCallStack)
import Numeric (showFFloat)
import System.Directory
  ( Permissions (executable)
  , createDirectory
  , doesDirectoryExist
  , doesFileExist
  , getModificationTime
  , getPermissions
  , getTemporaryDirectory
  , listDirectory
  , removeFile
  , removePathForcibly
  )
import System.Environment
  ( getProgName
  )
import System.FilePath (takeFileName)
import System.FilePath as FilePath
  ( getSearchPath
  , isExtensionOf
  , joinPath
  , normalise
  , searchPathSeparator
  , splitDirectories
  , splitExtension
  , stripExtension
  , takeDirectory
  )
import System.IO
  ( BufferMode (..)
  , Handle
  , hClose
  , hFlush
  , hGetContents
  , hPutStr
  , hPutStrLn
  , hSetBinaryMode
  , hSetBuffering
  , stderr
  , stdin
  , stdout
  )
import System.IO.Error
import System.IO.Unsafe
  ( unsafeInterleaveIO
  )
import qualified System.Info as SI
import qualified System.Process as Process
import qualified Text.PrettyPrint as Disp

#ifdef GIT_REV
import Data.Either (isLeft)
import GitHash
  ( giHash
  , giBranch
  , giCommitDate
  , tGitInfoCwdTry
  )
#endif

#if MIN_VERSION_base(4,21,0)
import Control.Exception.Context
#endif

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

-- |
-- `Cabal` Git information. Only filled in if built in a Git tree in
-- development mode and Template Haskell is available.
cabalGitInfo :: String
#ifdef GIT_REV
cabalGitInfo = if giHash' == ""
                 then ""
                 else concat [ "(commit "
                             , giHash'
                             , branchInfo
                             , either (const "") ((", " ++) . giCommitDate) gi'
                             , ")"
                             ]
  where
    gi' = $$tGitInfoCwdTry
    giHash' = take 7 . either (const "") giHash $ gi'
    branch = either id giBranch gi'
    branchInfo | isLeft gi' = ""
               | branch == "master" = ""
               | otherwise = " on " <> branch
#else
cabalGitInfo :: [Char]
cabalGitInfo = [Char]
""
#endif

-- |
-- `Cabal` compiler information, reported by `--version-full` but otherwise
-- unused.
cabalCompilerInfo :: String
cabalCompilerInfo :: [Char]
cabalCompilerInfo =
  [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char]
SI.compilerName
    , [Char]
" "
    , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show (Version -> [Int]
DV.versionBranch Version
SIC.fullCompilerVersion))
    , [Char]
" on "
    , [Char]
SI.os
    , [Char]
" "
    , [Char]
SI.arch
    ]

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

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

dieNoVerbosity :: String -> IO a
dieNoVerbosity :: forall a. [Char] -> IO a
dieNoVerbosity [Char]
msg =
  IOException -> IO a
forall a. HasCallStack => IOException -> IO a
ioError ([Char] -> IOException
userError [Char]
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 :: IOException -> IOException
ioeSetVerbatim IOException
e = IOException -> [Char] -> IOException
ioeSetLocation IOException
e [Char]
"dieVerbatim"

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

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

dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
dieWithLocation' :: forall a. Verbosity -> [Char] -> Maybe Int -> [Char] -> IO a
dieWithLocation' Verbosity
verbosity [Char]
filename Maybe Int
mb_lineno [Char]
msg =
  Verbosity -> [Char] -> IO a
forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$
    [Char]
filename
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ( case Maybe Int
mb_lineno of
            Just Int
lineno -> [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
lineno
            Maybe Int
Nothing -> [Char]
""
         )
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg

die' :: Verbosity -> String -> IO a
die' :: forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity [Char]
msg = (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ do
  IOException -> IO a
forall a. HasCallStack => IOException -> IO a
ioError (IOException -> IO a) -> ([Char] -> IOException) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOException
verbatimUserError
    ([Char] -> IO a) -> IO [Char] -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> [Char] -> IO [Char]
annotateErrorString Verbosity
verbosity
    ([Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> ([Char] -> [Char]) -> [Char] -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerbosityFlags -> [Char] -> [Char]
wrapTextVerbosity (Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity)
    ([Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> ([Char] -> [Char]) -> [Char] -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
addErrorPrefix
    ([Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [Char]
prefixWithProgName [Char]
msg

-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions
data VerboseException a = VerboseException CallStack POSIXTime VerbosityFlags a
  deriving (Int -> VerboseException a -> [Char] -> [Char]
[VerboseException a] -> [Char] -> [Char]
VerboseException a -> [Char]
(Int -> VerboseException a -> [Char] -> [Char])
-> (VerboseException a -> [Char])
-> ([VerboseException a] -> [Char] -> [Char])
-> Show (VerboseException a)
forall a. Show a => Int -> VerboseException a -> [Char] -> [Char]
forall a. Show a => [VerboseException a] -> [Char] -> [Char]
forall a. Show a => VerboseException a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Show a => Int -> VerboseException a -> [Char] -> [Char]
showsPrec :: Int -> VerboseException a -> [Char] -> [Char]
$cshow :: forall a. Show a => VerboseException a -> [Char]
show :: VerboseException a -> [Char]
$cshowList :: forall a. Show a => [VerboseException a] -> [Char] -> [Char]
showList :: [VerboseException a] -> [Char] -> [Char]
Show)

-- Function which will replace the existing die' call sites
dieWithException :: (HasCallStack, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a
dieWithException :: forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity a1
exception = do
  ts <- IO NominalDiffTime
getPOSIXTime
  throwIO $ VerboseException callStack ts (verbosityFlags verbosity) exception

-- Instance for Cabal Exception which will display error code and error message with callStack info
instance Exception (VerboseException CabalException) where
  displayException :: VerboseException CabalException -> [Char]
  displayException :: VerboseException CabalException -> [Char]
displayException (VerboseException CallStack
stack NominalDiffTime
timestamp VerbosityFlags
verb CabalException
cabalexception) =
    VerbosityFlags -> [Char] -> [Char]
withOutputMarker
      VerbosityFlags
verb
      ( [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [Char]
"Error: [Cabal-"
          , Int -> [Char]
forall a. Show a => a -> [Char]
show (CabalException -> Int
exceptionCode CabalException
cabalexception)
          , [Char]
"]\n"
          ]
      )
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallStack -> NominalDiffTime -> VerbosityFlags -> [Char] -> [Char]
exceptionWithMetadata CallStack
stack NominalDiffTime
timestamp VerbosityFlags
verb (CabalException -> [Char]
exceptionMessage CabalException
cabalexception)

dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap :: forall a. Verbosity -> [Char] -> IO a
dieNoWrap Verbosity
verbosity [Char]
msg = (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ do
  -- TODO: should this have program name or not?
  IOException -> IO a
forall a. HasCallStack => IOException -> IO a
ioError (IOException -> IO a) -> ([Char] -> IOException) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOException
verbatimUserError
    ([Char] -> IO a) -> IO [Char] -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> [Char] -> IO [Char]
annotateErrorString
      Verbosity
verbosity
      ([Char] -> [Char]
addErrorPrefix [Char]
msg)

-- | Prefixing a message to indicate that it is a fatal error,
-- if the 'errorPrefix' is not already present.
addErrorPrefix :: String -> String
addErrorPrefix :: [Char] -> [Char]
addErrorPrefix [Char]
msg
  | [Char]
errorPrefix [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
msg = [Char]
msg
  -- Backpack prefixes its errors already with "Error:", see
  -- 'Distribution.Utils.LogProgress.dieProgress'.
  -- Taking it away there destroys the layout, so we rather
  -- check here whether the prefix is already present.
  | Bool
otherwise = [[Char]] -> [Char]
unwords [[Char]
errorPrefix, [Char]
msg]

-- | A prefix indicating that a message is a fatal error.
errorPrefix :: String
errorPrefix :: [Char]
errorPrefix = [Char]
"Error:"

-- | Prefix an error string with program name from 'getProgName'
prefixWithProgName :: String -> IO String
prefixWithProgName :: [Char] -> IO [Char]
prefixWithProgName [Char]
msg = do
  pname <- IO [Char]
getProgName
  return $ pname ++ ": " ++ msg

-- | Annotate an error string with timestamp and 'withMetadata'.
annotateErrorString :: Verbosity -> String -> IO String
annotateErrorString :: Verbosity -> [Char] -> IO [Char]
annotateErrorString Verbosity
verbosity [Char]
msg = do
  ts <- IO NominalDiffTime
getPOSIXTime
  return $ withMetadata ts AlwaysMark VerboseTrace (verbosityFlags verbosity) 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 :: forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity IO a
act = do
  ts <- IO NominalDiffTime
getPOSIXTime
  flip modifyIOError act $
    ioeModifyErrorString $
      withMetadata ts NeverMark VerboseTrace (verbosityFlags verbosity)

-- | A semantic editor for the error message inside an 'IOError'.
ioeModifyErrorString :: (String -> String) -> IOError -> IOError
ioeModifyErrorString :: ([Char] -> [Char]) -> IOException -> IOException
ioeModifyErrorString = ASetter IOException IOException [Char] [Char]
-> ([Char] -> [Char]) -> IOException -> IOException
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter IOException IOException [Char] [Char]
Lens' IOException [Char]
ioeErrorString

-- | A lens for the error message inside an 'IOError'.
ioeErrorString :: Lens' IOError String
ioeErrorString :: Lens' IOException [Char]
ioeErrorString [Char] -> f [Char]
f IOException
ioe = IOException -> [Char] -> IOException
ioeSetErrorString IOException
ioe ([Char] -> IOException) -> f [Char] -> f IOException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> f [Char]
f (IOException -> [Char]
ioeGetErrorString IOException
ioe)

-- | Check that the type of the exception matches the given user error type.
isUserException :: forall user_err. Typeable user_err => Proxy user_err -> Exception.SomeException -> Bool
isUserException :: forall user_err.
Typeable user_err =>
Proxy user_err -> SomeException -> Bool
isUserException Proxy user_err
Proxy (SomeException e
se) =
  case e -> Maybe user_err
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
se :: Maybe user_err of
    Just{} -> Bool
True
    Maybe user_err
Nothing -> Bool
False

{-# NOINLINE topHandlerWith #-}
topHandlerWith
  :: forall a
   . (Exception.SomeException -> Bool)
  -- ^ Identify when the error is an exception to display to users.
  -> (Exception.SomeException -> IO a)
  -> IO a
  -> IO a
topHandlerWith :: forall a.
(SomeException -> Bool) -> (SomeException -> IO a) -> IO a -> IO a
topHandlerWith SomeException -> Bool
is_user_exception SomeException -> IO a
cont IO a
prog = do
  -- By default, stderr to a terminal device is NoBuffering. But this
  -- is *really slow*
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
  IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
Exception.catches
    IO a
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 -> IO a
    rethrowAsyncExceptions :: AsyncException -> IO a
rethrowAsyncExceptions AsyncException
a = AsyncException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO AsyncException
a

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

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

    message :: String -> Exception.SomeException -> String
    message :: [Char] -> SomeException -> [Char]
message [Char]
pname e :: SomeException
e@(Exception.SomeException e
se) =
      case e -> Maybe IOException
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
se :: Maybe Exception.IOException of
        Just IOException
ioe
          | IOException -> Bool
ioeGetVerbatim IOException
ioe ->
              -- Use the message verbatim
              IOException -> [Char]
ioeGetErrorString IOException
ioe [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
          | IOException -> Bool
isUserError IOException
ioe ->
              let file :: [Char]
file = case IOException -> Maybe [Char]
ioeGetFileName IOException
ioe of
                    Maybe [Char]
Nothing -> [Char]
""
                    Just [Char]
path -> [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
location [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
                  location :: [Char]
location = case IOException -> [Char]
ioeGetLocation IOException
ioe of
                    l :: [Char]
l@(Char
n : [Char]
_) | Char -> Bool
isDigit Char
n -> Char
':' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
l
                    [Char]
_ -> [Char]
""
                  detail :: [Char]
detail = IOException -> [Char]
ioeGetErrorString IOException
ioe
               in [Char] -> [Char]
wrapText ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
addErrorPrefix ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
pname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
detail
        -- Don't print a call stack for a "user exception"
        Maybe IOException
_
          | SomeException -> Bool
is_user_exception SomeException
e -> SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e
          -- Other errors which have are not intended for user display, print with a callstack.
          | Bool
otherwise -> SomeException -> [Char]
displaySomeExceptionWithContext SomeException
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

-- | BC wrapper around 'Exception.displayException'.
displaySomeExceptionWithContext :: SomeException -> String
#if MIN_VERSION_base(4,21,0)
displaySomeExceptionWithContext :: SomeException -> [Char]
displaySomeExceptionWithContext (SomeException e
e) =
  case ExceptionContext -> [Char]
displayExceptionContext ExceptionContext
forall (x :: Symbol) a. IP x a => a
?exceptionContext of
    [Char]
"" -> [Char]
msg
    [Char]
dc -> [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
dc
  where
    msg :: [Char]
msg = e -> [Char]
forall e. Exception e => e -> [Char]
displayException e
e
#else
displaySomeExceptionWithContext e = displayException e
#endif

topHandler :: (Exception.SomeException -> Bool) -> IO a -> IO a
topHandler :: forall a. (SomeException -> Bool) -> IO a -> IO a
topHandler SomeException -> Bool
is_user_exception IO a
prog = (SomeException -> Bool) -> (SomeException -> IO a) -> IO a -> IO a
forall a.
(SomeException -> Bool) -> (SomeException -> IO a) -> IO a -> IO a
topHandlerWith SomeException -> Bool
is_user_exception (IO a -> SomeException -> IO a
forall a b. a -> b -> a
const (IO a -> SomeException -> IO a) -> IO a -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)) IO a
prog

-- | Non fatal conditions that may be indicative of an error or problem.
--
-- We display these at the 'normal' verbosity level.
warn :: Verbosity -> String -> IO ()
warn :: Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
msg = [Char] -> Verbosity -> [Char] -> IO ()
warnMessage [Char]
"Warning" Verbosity
verbosity [Char]
msg

-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the
-- the message. Useful when you want to highlight the condition is an error
-- but do not want to quit the program yet.
warnError :: Verbosity -> String -> IO ()
warnError :: Verbosity -> [Char] -> IO ()
warnError Verbosity
verbosity [Char]
message = [Char] -> Verbosity -> [Char] -> IO ()
warnMessage [Char]
"Error" Verbosity
verbosity [Char]
message

-- | Warning message, with a custom label.
warnMessage :: String -> Verbosity -> String -> IO ()
warnMessage :: [Char] -> Verbosity -> [Char] -> IO ()
warnMessage [Char]
l Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Normal Bool -> Bool -> Bool
&& Bool -> Bool
not (VerbosityFlags -> Bool
isVerboseNoWarn VerbosityFlags
flags)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ts <- IO NominalDiffTime
getPOSIXTime
    let outHandle = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        errHandle = Verbosity -> Handle
verbosityErrorHandle Verbosity
verbosity
    hFlush outHandle
    hPutStr errHandle
      . withMetadata ts NormalMark FlagTrace flags
      . wrapTextVerbosity flags
      $ l ++ ": " ++ msg
  where
    flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity

-- | 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 -> [Char] -> IO ()
notice Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NormalMark FlagTrace flags $
        wrapTextVerbosity flags msg

-- | Display a message at 'normal' verbosity level, but without
-- wrapping.
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap :: Verbosity -> [Char] -> IO ()
noticeNoWrap Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h . withMetadata ts NormalMark FlagTrace flags $ msg

-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
-- level.  Use this if you need fancy formatting.
noticeDoc :: Verbosity -> Disp.Doc -> IO ()
noticeDoc :: Verbosity -> Doc -> IO ()
noticeDoc Verbosity
verbosity Doc
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NormalMark FlagTrace flags $
        Disp.renderStyle defaultStyle msg

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

-- | More detail on the operation of some action.
--
-- We display these messages when the verbosity level is 'verbose'
info :: Verbosity -> String -> IO ()
info :: Verbosity -> [Char] -> IO ()
info Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NeverMark FlagTrace flags $
        wrapTextVerbosity flags msg

infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap :: Verbosity -> [Char] -> IO ()
infoNoWrap Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NeverMark FlagTrace flags msg

-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
debug :: Verbosity -> String -> IO ()
debug :: Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
        flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NeverMark FlagTrace flags $
        wrapTextVerbosity flags msg
    -- ensure that we don't lose output if we segfault/infinite loop
    hFlush stdout

-- | A variant of 'debug' that doesn't perform the automatic line
-- wrapping. Produces better output in some cases.
debugNoWrap :: Verbosity -> String -> IO ()
debugNoWrap :: Verbosity -> [Char] -> IO ()
debugNoWrap Verbosity
verbosity [Char]
msg = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> VerbosityLevel
verbosityLevel Verbosity
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let h :: Handle
h = Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
    ts <- IO NominalDiffTime
getPOSIXTime
    hPutStr h $
      withMetadata ts NeverMark FlagTrace (verbosityFlags verbosity) msg
    -- ensure that we don't lose output if we segfault/infinite loop
    hFlush stdout

-- | Perform an IO action, catching any IO exceptions and printing an error
--   if one occurs.
chattyTry
  :: Verbosity
  -> String
  -- ^ a description of the action we were attempting
  -> IO ()
  -- ^ the action itself
  -> IO ()
chattyTry :: Verbosity -> [Char] -> IO () -> IO ()
chattyTry Verbosity
verbosity [Char]
desc IO ()
action =
  IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO ()
action ((IOException -> IO ()) -> IO ())
-> (IOException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
exception ->
    Handle -> [Char] -> IO ()
hPutStrLn (Verbosity -> Handle
verbosityErrorHandle Verbosity
verbosity) ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char]
"Error while " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
desc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
exception

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

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

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

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

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

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

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

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

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

-- | Determine if we should emit a call stack.
-- If we trace, it also emits any prefix we should append.
traceWhen :: VerbosityFlags -> TraceWhen -> Maybe String
traceWhen :: VerbosityFlags -> TraceWhen -> Maybe [Char]
traceWhen VerbosityFlags
_ TraceWhen
AlwaysTrace = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
""
traceWhen VerbosityFlags
v TraceWhen
VerboseTrace | VerbosityFlags -> VerbosityLevel
vLevel VerbosityFlags
v VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Verbose = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
""
traceWhen VerbosityFlags
v TraceWhen
FlagTrace | VerbosityFlags -> Bool
isVerboseCallStack VerbosityFlags
v = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"----\n"
traceWhen VerbosityFlags
_ TraceWhen
_ = Maybe [Char]
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 -> VerbosityFlags -> String -> String)
withMetadata :: WithCallStack
  (NominalDiffTime
   -> MarkWhen -> TraceWhen -> VerbosityFlags -> [Char] -> [Char])
withMetadata NominalDiffTime
ts MarkWhen
marker TraceWhen
tracer VerbosityFlags
verbosity [Char]
x =
  (HasCallStack => [Char]) -> [Char]
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
    ((HasCallStack => [Char]) -> [Char])
-> (HasCallStack => [Char]) -> [Char]
forall a b. (a -> b) -> a -> b
$
    -- NB: order matters.  Output marker first because we
    -- don't want to capture call stacks.
    [Char] -> [Char]
withTrailingNewline
      ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack (TraceWhen -> VerbosityFlags -> [Char] -> [Char])
TraceWhen -> VerbosityFlags -> [Char] -> [Char]
withCallStackPrefix TraceWhen
tracer VerbosityFlags
verbosity
      ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( case MarkWhen
marker of
            MarkWhen
AlwaysMark -> VerbosityFlags -> [Char] -> [Char]
withOutputMarker VerbosityFlags
verbosity
            MarkWhen
NormalMark
              | Bool -> Bool
not (VerbosityFlags -> Bool
isVerboseQuiet VerbosityFlags
verbosity) ->
                  VerbosityFlags -> [Char] -> [Char]
withOutputMarker VerbosityFlags
verbosity
              | Bool
otherwise ->
                  [Char] -> [Char]
forall a. a -> a
id
            MarkWhen
NeverMark -> [Char] -> [Char]
forall a. a -> a
id
        )
      -- Clear out any existing markers
      ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
clearMarkers
      ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerbosityFlags -> NominalDiffTime -> [Char] -> [Char]
withTimestamp VerbosityFlags
verbosity NominalDiffTime
ts
    ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
x

-- | Add all necessary metadata to a logging message
exceptionWithMetadata :: CallStack -> POSIXTime -> VerbosityFlags -> String -> String
exceptionWithMetadata :: CallStack -> NominalDiffTime -> VerbosityFlags -> [Char] -> [Char]
exceptionWithMetadata CallStack
stack NominalDiffTime
ts VerbosityFlags
verbosity [Char]
x =
  [Char] -> [Char]
withTrailingNewline
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> VerbosityFlags -> [Char] -> [Char]
exceptionWithCallStackPrefix CallStack
stack VerbosityFlags
verbosity
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerbosityFlags -> [Char] -> [Char]
withOutputMarker VerbosityFlags
verbosity
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
clearMarkers
    ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerbosityFlags -> NominalDiffTime -> [Char] -> [Char]
withTimestamp VerbosityFlags
verbosity NominalDiffTime
ts
    ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
x

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

-- | Append a call-site and/or call-stack based on Verbosity
exceptionWithCallStackPrefix :: CallStack -> VerbosityFlags -> String -> String
exceptionWithCallStackPrefix :: CallStack -> VerbosityFlags -> [Char] -> [Char]
exceptionWithCallStackPrefix CallStack
stack VerbosityFlags
verbosity [Char]
s =
  [Char]
s
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (HasCallStack => [Char]) -> [Char]
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
      ( ( if VerbosityFlags -> Bool
isVerboseCallSite VerbosityFlags
verbosity
            then
              [Char]
HasCallStack => [Char]
parentSrcLocPrefix
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                -- Hack: need a newline before starting output marker :(
                if VerbosityFlags -> Bool
isVerboseMarkOutput VerbosityFlags
verbosity
                  then [Char]
"\n"
                  else [Char]
""
            else [Char]
""
        )
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ( if VerbosityFlags -> VerbosityLevel
vLevel VerbosityFlags
verbosity VerbosityLevel -> VerbosityLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= VerbosityLevel
Verbose
                then CallStack -> [Char]
prettyCallStack CallStack
stack [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                else [Char]
""
             )
      )

-- -----------------------------------------------------------------------------
-- rawSystem variants
--
-- These all use 'Distribution.Compat.Process.proc' to ensure we
-- consistently use process jobs on Windows and Ctrl-C delegation
-- on Unix.
--
-- Additionally, they take care of logging command execution.
--

-- | Helper to use with one of the 'rawSystem' variants, and exit
-- unless the command completes successfully.
maybeExit :: IO ExitCode -> IO ()
maybeExit :: IO ExitCode -> IO ()
maybeExit IO ExitCode
cmd = do
  exitcode <- IO ExitCode
cmd
  unless (exitcode == ExitSuccess) $ exitWith exitcode

-- | Log a command execution (that's typically about to happen)
-- at info level, and log working directory and environment overrides
-- at debug level if specified.
logCommand :: Verbosity -> Process.CreateProcess -> IO ()
logCommand :: Verbosity -> CreateProcess -> IO ()
logCommand Verbosity
verbosity CreateProcess
cp = do
  Verbosity -> [Char] -> IO ()
infoNoWrap Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"Running: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> case CreateProcess -> CmdSpec
Process.cmdspec CreateProcess
cp of
      Process.ShellCommand [Char]
sh -> [Char]
sh
      Process.RawCommand [Char]
path [[Char]]
args -> [Char] -> [[Char]] -> [Char]
Process.showCommandForUser [Char]
path [[Char]]
args
  case CreateProcess -> Maybe [([Char], [Char])]
Process.env CreateProcess
cp of
    Just [([Char], [Char])]
env -> Verbosity -> [Char] -> IO ()
debugNoWrap Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"with environment: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
forall a. Show a => a -> [Char]
show [([Char], [Char])]
env
    Maybe [([Char], [Char])]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case CreateProcess -> Maybe [Char]
Process.cwd CreateProcess
cp of
    Just [Char]
cwd -> Verbosity -> [Char] -> IO ()
debugNoWrap Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"with working directory: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
cwd
    Maybe [Char]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Handle -> IO ()
hFlush Handle
stdout

-- | Execute the given command with the given arguments, exiting
-- with the same exit code if the command fails.
rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO ()
rawSystemExit :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Char]
-> [[Char]]
-> IO ()
rawSystemExit Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [Char]
path [[Char]]
args =
  (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO ExitCode -> IO ()
maybeExit (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> IO ExitCode
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> IO ExitCode
rawSystemExitCode Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [Char]
path [[Char]]
args Maybe [([Char], [Char])]
forall a. Maybe a
Nothing

-- | Execute the given command with the given arguments, returning
-- the command's exit code.
rawSystemExitCode
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir to))
  -> FilePath
  -> [String]
  -> Maybe [(String, String)]
  -> IO ExitCode
rawSystemExitCode :: forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> IO ExitCode
rawSystemExitCode Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir to))
mbWorkDir [Char]
path [[Char]]
args Maybe [([Char], [Char])]
menv =
  (HasCallStack => IO ExitCode) -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ExitCode) -> IO ExitCode)
-> (HasCallStack => IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
    ((ExitCode, ()) -> ExitCode) -> IO (ExitCode, ()) -> IO ExitCode
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExitCode, ()) -> ExitCode
forall a b. (a, b) -> a
fst (IO (ExitCode, ()) -> IO ExitCode)
-> IO (ExitCode, ()) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
      Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, ())
forall a.
Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction
        Verbosity
verbosity
        [Char]
path
        [[Char]]
args
        ((SymbolicPath CWD ('Dir to) -> [Char])
-> Maybe (SymbolicPath CWD ('Dir to)) -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolicPath CWD ('Dir to) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath Maybe (SymbolicPath CWD ('Dir to))
mbWorkDir)
        Maybe [([Char], [Char])]
menv
        (\Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Maybe Handle
forall a. Maybe a
Nothing
        Maybe Handle
forall a. Maybe a
Nothing
        Maybe Handle
forall a. Maybe a
Nothing

-- | Execute the given command with the given arguments, returning
-- the command's exit code.
--
-- Create the process argument with 'Distribution.Compat.Process.proc'
-- to ensure consistent options with other 'rawSystem' functions in this
-- module.
rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode
rawSystemProc :: Verbosity -> CreateProcess -> IO ExitCode
rawSystemProc Verbosity
verbosity CreateProcess
cp = (HasCallStack => IO ExitCode) -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ExitCode) -> IO ExitCode)
-> (HasCallStack => IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
  (exitcode, _) <- Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> IO (ExitCode, ())
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction Verbosity
verbosity CreateProcess
cp ((Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
 -> IO (ExitCode, ()))
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> IO (ExitCode, ())
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  return exitcode

-- | Execute the given command with the given arguments, returning
-- the command's exit code. 'action' is executed while the command
-- is running, and would typically be used to communicate with the
-- process through pipes.
--
-- Create the process argument with 'Distribution.Compat.Process.proc'
-- to ensure consistent options with other 'rawSystem' functions in this
-- module.
rawSystemProcAction
  :: Verbosity
  -> Process.CreateProcess
  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
  -> IO (ExitCode, a)
rawSystemProcAction :: forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction Verbosity
verbosity CreateProcess
cp Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a
action = (HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a))
-> (HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a)
forall a b. (a -> b) -> a -> b
$ do
  Verbosity -> CreateProcess -> IO ()
logCommand Verbosity
verbosity CreateProcess
cp
  (exitcode, a) <- Verbosity
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, a))
-> IO (ExitCode, a)
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
compatWithCreateProcess Verbosity
verbosity CreateProcess
cp ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (ExitCode, a))
 -> IO (ExitCode, a))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, a))
-> IO (ExitCode, a)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mStdin Maybe Handle
mStdout Maybe Handle
mStderr ProcessHandle
p -> do
    a <- Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a
action Maybe Handle
mStdin Maybe Handle
mStdout Maybe Handle
mStderr
    exitcode <- Process.waitForProcess p
    return (exitcode, a)
  unless (exitcode == ExitSuccess) $ do
    let cmd = case CreateProcess -> CmdSpec
Process.cmdspec CreateProcess
cp of
          Process.ShellCommand [Char]
sh -> [Char]
sh
          Process.RawCommand [Char]
path [[Char]]
_args -> [Char]
path
    debug verbosity $ cmd ++ " returned " ++ show exitcode
  return (exitcode, a)

-- | A version of 'Process.withCreateProcess' that is careful to not close
-- the handles stored in 'Verbosity'.
compatWithCreateProcess
  :: Verbosity
  -> Process.CreateProcess
  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> Process.ProcessHandle -> IO a)
  -> IO a
compatWithCreateProcess :: forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
compatWithCreateProcess Verbosity
verbosity CreateProcess
cp Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
action =
  IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
create
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Process.cleanupProcess
    (\(Maybe Handle
m_in, Maybe Handle
m_out, Maybe Handle
m_err, ProcessHandle
ph) -> Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a
action Maybe Handle
m_in Maybe Handle
m_out Maybe Handle
m_err ProcessHandle
ph)
  where
    -- The 'process' documentation for 'createProcess'/'withCreateProcess'
    -- states:
    --
    --   Note that `Handle`s provided for `std_in`, `std_out`, or `std_err` via the
    --   `UseHandle` constructor will be closed by calling this function.
    --
    -- We don't want that, because we don't want the Verbosity handles being
    -- closed if they are passed to the subprocess, which would prevent
    -- us from continuing logging.
    --
    -- To avoid this, we copy the implementation of 'withCreateProcess' in terms
    -- of 'withCreateProcess_', but with special logic to avoid closing the
    -- verbosity handles.
    create :: IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
create =
      [Char]
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess_ [Char]
"createProcess" CreateProcess
cp
        IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. IO a -> IO b -> IO a
`Exception.finally` do
          StdStream -> IO ()
maybeClose (CreateProcess -> StdStream
Process.std_in CreateProcess
cp)
          StdStream -> IO ()
maybeClose (CreateProcess -> StdStream
Process.std_out CreateProcess
cp)
          StdStream -> IO ()
maybeClose (CreateProcess -> StdStream
Process.std_err CreateProcess
cp)

    maybeClose :: Process.StdStream -> IO ()
    maybeClose :: StdStream -> IO ()
maybeClose (Process.UseHandle Handle
hdl)
      | Handle
hdl
          Handle -> [Handle] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Handle
stdin
                 , Handle
stdout
                 , Handle
stderr
                 , VerbosityHandles -> Handle
vStdoutHandle (Verbosity -> VerbosityHandles
verbosityHandles Verbosity
verbosity)
                 , VerbosityHandles -> Handle
vStderrHandle (Verbosity -> VerbosityHandles
verbosityHandles Verbosity
verbosity)
                 ] -- Don't close the verbosity handles!
        =
          () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise =
          Handle -> IO ()
hClose Handle
hdl
    maybeClose StdStream
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | fromJust for dealing with 'Maybe Handle' values as obtained via
-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees
-- a 'Just' value for the corresponding handle.
fromCreatePipe :: Maybe Handle -> Handle
fromCreatePipe :: Maybe Handle -> Handle
fromCreatePipe = Handle -> Maybe Handle -> Handle
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Handle
forall a. HasCallStack => [Char] -> a
error [Char]
"fromCreatePipe: Nothing")

-- | Execute the given command with the given arguments and
-- environment, exiting with the same exit code if the command fails.
rawSystemExitWithEnv
  :: Verbosity
  -> FilePath
  -> [String]
  -> [(String, String)]
  -> IO ()
rawSystemExitWithEnv :: Verbosity -> [Char] -> [[Char]] -> [([Char], [Char])] -> IO ()
rawSystemExitWithEnv Verbosity
verbosity =
  Verbosity
-> Maybe (SymbolicPath CWD ('Dir to_5))
-> [Char]
-> [[Char]]
-> [([Char], [Char])]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> [([Char], [Char])]
-> IO ()
rawSystemExitWithEnvCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir to_5))
forall a. Maybe a
Nothing

-- | Like 'rawSystemExitWithEnv', but setting a working directory.
rawSystemExitWithEnvCwd
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir to))
  -> FilePath
  -> [String]
  -> [(String, String)]
  -> IO ()
rawSystemExitWithEnvCwd :: forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> [([Char], [Char])]
-> IO ()
rawSystemExitWithEnvCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir to))
mbWorkDir [Char]
path [[Char]]
args [([Char], [Char])]
env =
  (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO ExitCode -> IO ()
maybeExit (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> IO ExitCode
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> [Char]
-> [[Char]]
-> Maybe [([Char], [Char])]
-> IO ExitCode
rawSystemExitCode Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir to))
mbWorkDir [Char]
path [[Char]]
args ([([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just [([Char], [Char])]
env)

-- | Execute the given command with the given arguments, returning
-- the command's exit code.
--
-- Optional arguments allow setting working directory, environment
-- and input and output handles.
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
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv Verbosity
verbosity [Char]
path [[Char]]
args Maybe [Char]
mcwd Maybe [([Char], [Char])]
menv Maybe Handle
inp Maybe Handle
out Maybe Handle
err = (HasCallStack => IO ExitCode) -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ExitCode) -> IO ExitCode)
-> (HasCallStack => IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
  (exitcode, _) <-
    Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO ())
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, ())
forall a.
Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction
      Verbosity
verbosity
      [Char]
path
      [[Char]]
args
      Maybe [Char]
mcwd
      Maybe [([Char], [Char])]
menv
      (\Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ -> IO ()
action)
      Maybe Handle
inp
      Maybe Handle
out
      Maybe Handle
err
  return exitcode
  where
    action :: IO ()
action = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Execute the given command with the given arguments, returning
-- the command's exit code. 'action' is executed while the command
-- is running, and would typically be used to communicate with the
-- process through pipes.
--
-- Optional arguments allow setting working directory, environment
-- and input and output handles.
rawSystemIOWithEnvAndAction
  :: Verbosity
  -> FilePath
  -> [String]
  -- ^ arguments
  -> Maybe FilePath
  -- ^ New working dir or inherit
  -> Maybe [(String, String)]
  -- ^ New environment or inherit
  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
  -- ^ action to perform after process is created, but before 'waitForProcess'.
  -> Maybe Handle
  -- ^ stdin
  -> Maybe Handle
  -- ^ stdout
  -> Maybe Handle
  -- ^ stderr
  -> IO (ExitCode, a)
rawSystemIOWithEnvAndAction :: forall a.
Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction Verbosity
verbosity [Char]
path [[Char]]
args Maybe [Char]
mcwd Maybe [([Char], [Char])]
menv Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a
action Maybe Handle
inp Maybe Handle
out Maybe Handle
err =
  (HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a))
-> (HasCallStack => IO (ExitCode, a)) -> IO (ExitCode, a)
forall a b. (a -> b) -> a -> b
$ do
    -- If the output/error handle is Nothing, we need to use the corresponding
    -- logging handle stored in 'Verbosity'.
    let
      outHandle :: Handle
outHandle =
        case Maybe Handle
out of
          Just Handle
h -> Handle
h
          Maybe Handle
Nothing -> Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity
      errHandle :: Handle
errHandle =
        case Maybe Handle
err of
          Just Handle
h -> Handle
h
          Maybe Handle
Nothing -> Verbosity -> Handle
verbosityErrorHandle Verbosity
verbosity

    let cp :: CreateProcess
cp =
          ([Char] -> [[Char]] -> CreateProcess
proc [Char]
path [[Char]]
args)
            { Process.cwd = mcwd
            , Process.env = menv
            , Process.std_in = maybe Process.Inherit Process.UseHandle inp
            , Process.std_out = Process.UseHandle outHandle
            , Process.std_err = Process.UseHandle errHandle
            }

    Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction Verbosity
verbosity CreateProcess
cp Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a
action

-- | Execute the given command with the given arguments, returning
-- the command's output. Exits if the command exits with error.
--
-- Provides control over the binary/text mode of the output.
rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode
rawSystemStdout :: forall mode.
KnownIODataMode mode =>
Verbosity -> [Char] -> [[Char]] -> IO mode
rawSystemStdout Verbosity
verbosity [Char]
path [[Char]]
args = (HasCallStack => IO mode) -> IO mode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO mode) -> IO mode)
-> (HasCallStack => IO mode) -> IO mode
forall a b. (a -> b) -> a -> b
$ do
  (output, errors, exitCode) <-
    Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, [Char], ExitCode)
forall mode.
KnownIODataMode mode =>
Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, [Char], ExitCode)
rawSystemStdInOut
      Verbosity
verbosity
      [Char]
path
      [[Char]]
args
      Maybe [Char]
forall a. Maybe a
Nothing
      Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
      Maybe IOData
forall a. Maybe a
Nothing
      (IODataMode mode
forall mode. KnownIODataMode mode => IODataMode mode
IOData.iodataMode :: IODataMode mode)
  when (exitCode /= ExitSuccess) $
    dieWithException verbosity $
      RawSystemStdout errors
  return output

-- | Execute the given command with the given arguments, returning
-- the command's output, errors and exit code.
--
-- Optional arguments allow setting working directory, environment
-- and command input.
--
-- Provides control over the binary/text mode of the input and output.
rawSystemStdInOut
  :: KnownIODataMode mode
  => Verbosity
  -> FilePath
  -- ^ Program location
  -> [String]
  -- ^ Arguments
  -> Maybe FilePath
  -- ^ New working dir or inherit
  -> Maybe [(String, String)]
  -- ^ New environment or inherit
  -> Maybe IOData
  -- ^ input text and binary mode
  -> IODataMode mode
  -- ^ iodata mode, acts as proxy
  -> IO (mode, String, ExitCode)
  -- ^ output, errors, exit
rawSystemStdInOut :: forall mode.
KnownIODataMode mode =>
Verbosity
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> Maybe IOData
-> IODataMode mode
-> IO (mode, [Char], ExitCode)
rawSystemStdInOut Verbosity
verbosity [Char]
path [[Char]]
args Maybe [Char]
mcwd Maybe [([Char], [Char])]
menv Maybe IOData
input IODataMode mode
_ = (HasCallStack => IO (mode, [Char], ExitCode))
-> IO (mode, [Char], ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO (mode, [Char], ExitCode))
 -> IO (mode, [Char], ExitCode))
-> (HasCallStack => IO (mode, [Char], ExitCode))
-> IO (mode, [Char], ExitCode)
forall a b. (a -> b) -> a -> b
$ do
  let cp :: CreateProcess
cp =
        ([Char] -> [[Char]] -> CreateProcess
proc [Char]
path [[Char]]
args)
          { Process.cwd = mcwd
          , Process.env = menv
          , Process.std_in = Process.CreatePipe
          , Process.std_out = Process.CreatePipe
          , Process.std_err = Process.CreatePipe
          }

  (exitcode, (mberr1, mberr2)) <- Verbosity
-> CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> IO (Either SomeException mode, Either SomeException [Char]))
-> IO
     (ExitCode,
      (Either SomeException mode, Either SomeException [Char]))
forall a.
Verbosity
-> CreateProcess
-> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
-> IO (ExitCode, a)
rawSystemProcAction Verbosity
verbosity CreateProcess
cp ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> IO (Either SomeException mode, Either SomeException [Char]))
 -> IO
      (ExitCode,
       (Either SomeException mode, Either SomeException [Char])))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> IO (Either SomeException mode, Either SomeException [Char]))
-> IO
     (ExitCode,
      (Either SomeException mode, Either SomeException [Char]))
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mb_in Maybe Handle
mb_out Maybe Handle
mb_err -> do
    let (Handle
inh, Handle
outh, Handle
errh) = (Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mb_in, Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mb_out, Maybe Handle -> Handle
fromCreatePipe Maybe Handle
mb_err)
    (IO (Either SomeException mode, Either SomeException [Char])
 -> IO ()
 -> IO (Either SomeException mode, Either SomeException [Char]))
-> IO ()
-> IO (Either SomeException mode, Either SomeException [Char])
-> IO (Either SomeException mode, Either SomeException [Char])
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either SomeException mode, Either SomeException [Char])
-> IO ()
-> IO (Either SomeException mode, Either SomeException [Char])
forall a b. IO a -> IO b -> IO a
Exception.finally (Handle -> IO ()
hClose Handle
inh IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
outh IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
errh) (IO (Either SomeException mode, Either SomeException [Char])
 -> IO (Either SomeException mode, Either SomeException [Char]))
-> IO (Either SomeException mode, Either SomeException [Char])
-> IO (Either SomeException mode, Either SomeException [Char])
forall a b. (a -> b) -> a -> b
$ do
      -- output mode depends on what the caller wants
      -- but the errors are always assumed to be text (in the current locale)
      Handle -> Bool -> IO ()
hSetBinaryMode Handle
errh Bool
False

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

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

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

  -- get the stderr, so it can be added to error message
  err <- reportOutputIOError mberr2

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

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

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

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

-- | Look for a program and try to find it's version number. It can accept
-- either an absolute path or the name of a program binary, in which case we
-- will look for the program on the path.
findProgramVersion
  :: String
  -- ^ version args
  -> (String -> String)
  -- ^ function to select version
  --   number from program output
  -> Verbosity
  -> FilePath
  -- ^ location
  -> IO (Maybe Version)
findProgramVersion :: [Char]
-> ([Char] -> [Char]) -> Verbosity -> [Char] -> IO (Maybe Version)
findProgramVersion [Char]
versionArg [Char] -> [Char]
selectVersion Verbosity
verbosity [Char]
path = (HasCallStack => IO (Maybe Version)) -> IO (Maybe Version)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO (Maybe Version)) -> IO (Maybe Version))
-> (HasCallStack => IO (Maybe Version)) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
  str <-
    Verbosity -> [Char] -> [[Char]] -> IO [Char]
forall mode.
KnownIODataMode mode =>
Verbosity -> [Char] -> [[Char]] -> IO mode
rawSystemStdout Verbosity
verbosity [Char]
path [[Char]
versionArg]
      IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")
      IO [Char]
-> (VerboseException CabalException -> IO [Char]) -> IO [Char]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(VerboseException CabalException
_ :: VerboseException CabalException) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")
      IO [Char] -> (ExitCode -> IO [Char]) -> IO [Char]
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"")
  let version :: Maybe Version
      version = [Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec ([Char] -> [Char]
selectVersion [Char]
str)
  case version of
    Maybe Version
Nothing ->
      Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"cannot determine version of "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
str
    Just Version
v -> Verbosity -> [Char] -> IO ()
debug Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is version " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
v
  return version

-- | Like the Unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
-- need to invoke a command multiple times to get all the args in.
--
-- Use it with either of the rawSystem variants above. For example:
--
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
xargs
  :: Int
  -> ([String] -> IO ())
  -> [String]
  -> [String]
  -> IO ()
xargs :: Int -> ([[Char]] -> IO ()) -> [[Char]] -> [[Char]] -> IO ()
xargs Int
maxSize [[Char]] -> IO ()
rawSystemFun [[Char]]
fixedArgs [[Char]]
bigArgs =
  let fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
fixedArgs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
fixedArgs
      chunkSize :: Int
chunkSize = Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize
   in ([[Char]] -> IO ()) -> [[[Char]]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([[Char]] -> IO ()
rawSystemFun ([[Char]] -> IO ()) -> ([[Char]] -> [[Char]]) -> [[Char]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Char]]
fixedArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++)) (Int -> [[Char]] -> [[[Char]]]
forall {t :: * -> *} {a}. Foldable t => Int -> [t a] -> [[t a]]
chunks Int
chunkSize [[Char]]
bigArgs)
  where
    chunks :: Int -> [t a] -> [[t a]]
chunks Int
len = ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]])
-> ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall a b. (a -> b) -> a -> b
$ \[t a]
s ->
      if [t a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t a]
s
        then Maybe ([t a], [t a])
forall a. Maybe a
Nothing
        else ([t a], [t a]) -> Maybe ([t a], [t a])
forall a. a -> Maybe a
Just ([t a] -> Int -> [t a] -> ([t a], [t a])
forall {t :: * -> *} {a}.
Foldable t =>
[t a] -> Int -> [t a] -> ([t a], [t a])
chunk [] Int
len [t a]
s)

    chunk :: [t a] -> Int -> [t a] -> ([t a], [t a])
chunk [t a]
acc Int
_ [] = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc, [])
    chunk [t a]
acc Int
len (t a
s : [t a]
ss)
      | Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = [t a] -> Int -> [t a] -> ([t a], [t a])
chunk (t a
s t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
: [t a]
acc) (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [t a]
ss
      | Bool
otherwise = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc, t a
s t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
: [t a]
ss)
      where
        len' :: Int
len' = t a -> Int
forall a. 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.
--
-- @since 3.4.0.0
findFileCwd
  :: forall searchDir allowAbsolute
   . Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ working directory
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ search directories
  -> RelativePath searchDir File
  -- ^ File Name
  -> IO (SymbolicPathX allowAbsolute Pkg File)
findFileCwd :: forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
findFileCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath SymbolicPathX 'OnlyRelative searchDir 'File
fileName =
  (SymbolicPathX allowAbsolute Pkg 'File -> [Char])
-> [SymbolicPathX allowAbsolute Pkg 'File]
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
forall a. (a -> [Char]) -> [a] -> IO (Maybe a)
findFirstFile
    (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir)
    [ SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> SymbolicPathX 'OnlyRelative searchDir 'File
-> SymbolicPathX allowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative searchDir 'File
fileName
    | SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path <- [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
forall a. Ord a => [a] -> [a]
ordNub [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath
    ]
    IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
-> (Maybe (SymbolicPathX allowAbsolute Pkg 'File)
    -> IO (SymbolicPathX allowAbsolute Pkg 'File))
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (SymbolicPathX allowAbsolute Pkg 'File)
-> (SymbolicPathX allowAbsolute Pkg 'File
    -> IO (SymbolicPathX allowAbsolute Pkg 'File))
-> Maybe (SymbolicPathX allowAbsolute Pkg 'File)
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity
-> CabalException -> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO (SymbolicPathX allowAbsolute Pkg 'File))
-> CabalException -> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalException
[Char] -> CabalException
FindFile ([Char] -> CabalException) -> [Char] -> CabalException
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'OnlyRelative searchDir 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPathX 'OnlyRelative searchDir 'File
fileName) SymbolicPathX allowAbsolute Pkg 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Find a file by looking in a search path. The file path must match exactly.
findFileEx
  :: forall searchDir allowAbsolute
   . Verbosity
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ search directories
  -> RelativePath searchDir File
  -- ^ File Name
  -> IO (SymbolicPathX allowAbsolute Pkg File)
findFileEx :: forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
findFileEx Verbosity
v = Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
findFileCwd Verbosity
v Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | 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
  :: [Suffix]
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -> RelativePath searchDir File
  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))
findFileWithExtension :: forall (allowAbsolute :: AllowAbsolute) searchDir.
[Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
findFileWithExtension =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
findFileCwdWithExtension Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | Find a file by looking in a search path with one of a list of possible
-- file extensions.
--
-- @since 3.4.0.0
findFileCwdWithExtension
  :: forall searchDir allowAbsolute
   . Maybe (SymbolicPath CWD (Dir Pkg))
  -> [Suffix]
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -> RelativePath searchDir File
  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File))
findFileCwdWithExtension :: forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
findFileCwdWithExtension Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [Suffix]
extensions [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath RelativePath searchDir 'File
baseName =
  ((SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
  RelativePath searchDir 'File)
 -> SymbolicPathX allowAbsolute Pkg 'File)
-> Maybe
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
-> Maybe (SymbolicPathX allowAbsolute Pkg 'File)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
 -> RelativePath searchDir 'File
 -> SymbolicPathX allowAbsolute Pkg 'File)
-> (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
    RelativePath searchDir 'File)
-> SymbolicPathX allowAbsolute Pkg 'File
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> RelativePath searchDir 'File
-> SymbolicPathX allowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
(</>))
    (Maybe
   (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
    RelativePath searchDir 'File)
 -> Maybe (SymbolicPathX allowAbsolute Pkg 'File))
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
-> IO (Maybe (SymbolicPathX allowAbsolute Pkg 'File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
findFileCwdWithExtension' Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [Suffix]
extensions [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath RelativePath searchDir 'File
baseName

-- | @since 3.4.0.0
findAllFilesCwdWithExtension
  :: forall searchDir allowAbsolute
   . Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ working directory
  -> [Suffix]
  -- ^ extensions
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ relative search locations
  -> RelativePath searchDir File
  -- ^ basename
  -> IO [SymbolicPathX allowAbsolute Pkg File]
findAllFilesCwdWithExtension :: forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO [SymbolicPathX allowAbsolute Pkg 'File]
findAllFilesCwdWithExtension Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [Suffix]
extensions [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath SymbolicPathX 'OnlyRelative searchDir 'File
basename =
  (SymbolicPathX allowAbsolute Pkg 'File -> [Char])
-> [SymbolicPathX allowAbsolute Pkg 'File]
-> IO [SymbolicPathX allowAbsolute Pkg 'File]
forall a. (a -> [Char]) -> [a] -> IO [a]
findAllFiles
    (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir)
    [ SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> SymbolicPathX 'OnlyRelative searchDir 'File
-> SymbolicPathX allowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative searchDir 'File
basename SymbolicPathX 'OnlyRelative searchDir 'File
-> [Char] -> SymbolicPathX 'OnlyRelative searchDir 'File
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
ext
    | SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path <- [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
forall a. Ord a => [a] -> [a]
ordNub [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath
    , Suffix [Char]
ext <- [Suffix] -> [Suffix]
forall a. Ord a => [a] -> [a]
ordNub [Suffix]
extensions
    ]

findAllFilesWithExtension
  :: [Suffix]
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -> RelativePath searchDir File
  -> IO [SymbolicPathX allowAbsolute Pkg File]
findAllFilesWithExtension :: forall (allowAbsolute :: AllowAbsolute) searchDir.
[Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO [SymbolicPathX allowAbsolute Pkg 'File]
findAllFilesWithExtension =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO [SymbolicPathX allowAbsolute Pkg 'File]
forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO [SymbolicPathX allowAbsolute Pkg 'File]
findAllFilesCwdWithExtension Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | 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'
  :: [Suffix]
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -> RelativePath searchDir File
  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))
findFileWithExtension' :: forall (allowAbsolute :: AllowAbsolute) searchDir.
[Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
findFileWithExtension' =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
findFileCwdWithExtension' Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | Like 'findFileCwdWithExtension' but returns which element of the search path
-- the file was found in, and the file path relative to that base directory.
findFileCwdWithExtension'
  :: forall searchDir allowAbsolute
   . Maybe (SymbolicPath CWD (Dir Pkg))
  -> [Suffix]
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -> RelativePath searchDir File
  -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File))
findFileCwdWithExtension' :: forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
findFileCwdWithExtension' Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [Suffix]
extensions [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath SymbolicPathX 'OnlyRelative searchDir 'File
baseName =
  ((SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
  SymbolicPathX 'OnlyRelative searchDir 'File)
 -> [Char])
-> [(SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
     SymbolicPathX 'OnlyRelative searchDir 'File)]
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         SymbolicPathX 'OnlyRelative searchDir 'File))
forall a. (a -> [Char]) -> [a] -> IO (Maybe a)
findFirstFile
    ((SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
 -> SymbolicPathX 'OnlyRelative searchDir 'File -> [Char])
-> (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
    SymbolicPathX 'OnlyRelative searchDir 'File)
-> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> SymbolicPathX 'OnlyRelative searchDir 'File -> [Char]
mkPath)
    [ (SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path, SymbolicPathX 'OnlyRelative searchDir 'File
baseName SymbolicPathX 'OnlyRelative searchDir 'File
-> [Char] -> SymbolicPathX 'OnlyRelative searchDir 'File
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
ext)
    | SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
path <- [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
forall a. Ord a => [a] -> [a]
ordNub [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath
    , Suffix [Char]
ext <- [Suffix] -> [Suffix]
forall a. Ord a => [a] -> [a]
ordNub [Suffix]
extensions
    ]
  where
    mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath
    mkPath :: SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> SymbolicPathX 'OnlyRelative searchDir 'File -> [Char]
mkPath SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
base SymbolicPathX 'OnlyRelative searchDir 'File
file =
      Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg 'File -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
cwd (SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
base SymbolicPathX allowAbsolute Pkg ('Dir searchDir)
-> SymbolicPathX 'OnlyRelative searchDir 'File
-> SymbolicPathX allowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative searchDir 'File
file)

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

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

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

-- | Finds the files corresponding to a list of Haskell module names.
--
-- As 'findModuleFileCwd' but for a list of module names.
findModuleFilesCwd
  :: forall searchDir allowAbsolute
   . Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ build prefix (location of objects)
  -> [Suffix]
  -- ^ search suffixes
  -> [ModuleName]
  -- ^ modules
  -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)]
findModuleFilesCwd :: forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> [ModuleName]
-> IO
     [(SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File)]
findModuleFilesCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath [Suffix]
extensions [ModuleName]
moduleNames =
  (ModuleName
 -> IO
      (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File))
-> [ModuleName]
-> IO
     [(SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
findModuleFileCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath [Suffix]
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.
findModuleFileEx
  :: forall searchDir allowAbsolute
   . Verbosity
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ build prefix (location of objects)
  -> [Suffix]
  -- ^ search suffixes
  -> ModuleName
  -- ^ module
  -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)
findModuleFileEx :: forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
findModuleFileEx Verbosity
verbosity =
  Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
findModuleFileCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | Find the file corresponding to a Haskell module name.
--
-- This is similar to 'findFileCwdWithExtension'' but specialised to a module
-- name. The function fails if the file corresponding to the module is missing.
findModuleFileCwd
  :: forall searchDir allowAbsolute
   . Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)]
  -- ^ build prefix (location of objects)
  -> [Suffix]
  -- ^ search suffixes
  -> ModuleName
  -- ^ module
  -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)
findModuleFileCwd :: forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> ModuleName
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
findModuleFileCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
cwd [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath [Suffix]
extensions ModuleName
mod_name = do
  mbRes <-
    Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
forall searchDir (allowAbsolute :: AllowAbsolute).
Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Suffix]
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO
     (Maybe
        (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
         RelativePath searchDir 'File))
findFileCwdWithExtension'
      Maybe (SymbolicPath CWD ('Dir Pkg))
cwd
      [Suffix]
extensions
      [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath
      ([Char] -> RelativePath searchDir 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char] -> RelativePath searchDir 'File)
-> [Char] -> RelativePath searchDir 'File
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
ModuleName.toFilePath ModuleName
mod_name)
  case mbRes of
    Maybe
  (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
   RelativePath searchDir 'File)
Nothing ->
      Verbosity
-> CabalException
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException
 -> IO
      (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File))
-> CabalException
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
forall a b. (a -> b) -> a -> b
$
        ModuleName -> [Suffix] -> [[Char]] -> CabalException
FindModuleFileEx ModuleName
mod_name [Suffix]
extensions ((SymbolicPathX allowAbsolute Pkg ('Dir searchDir) -> [Char])
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPathX allowAbsolute Pkg ('Dir searchDir) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
searchPath)
    Just (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
 RelativePath searchDir 'File)
res -> (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
 RelativePath searchDir 'File)
-> IO
     (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
      RelativePath searchDir 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
 RelativePath searchDir 'File)
res

-- | 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 :: [Char] -> IO [[Char]]
getDirectoryContentsRecursive [Char]
topdir = [[Char]] -> IO [[Char]]
recurseDirectories [[Char]
""]
  where
    recurseDirectories :: [FilePath] -> IO [FilePath]
    recurseDirectories :: [[Char]] -> IO [[Char]]
recurseDirectories [] = [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    recurseDirectories ([Char]
dir : [[Char]]
dirs) = IO [[Char]] -> IO [[Char]]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [[Char]] -> IO [[Char]]) -> IO [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ do
      (files, dirs') <- [[Char]] -> [[Char]] -> [[Char]] -> IO ([[Char]], [[Char]])
collect [] [] ([[Char]] -> IO ([[Char]], [[Char]]))
-> IO [[Char]] -> IO ([[Char]], [[Char]])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> IO [[Char]]
listDirectory ([Char]
topdir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
dir)
      files' <- recurseDirectories (dirs' ++ dirs)
      return (files ++ files')
      where
        collect :: [[Char]] -> [[Char]] -> [[Char]] -> IO ([[Char]], [[Char]])
collect [[Char]]
files [[Char]]
dirs' [] =
          ([[Char]], [[Char]]) -> IO ([[Char]], [[Char]])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
            ( [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
files
            , [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
dirs'
            )
        collect [[Char]]
files [[Char]]
dirs' ([Char]
entry : [[Char]]
entries) = do
          let dirEntry :: [Char]
dirEntry = [Char]
dir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
entry
          isDirectory <- [Char] -> IO Bool
doesDirectoryExist ([Char]
topdir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
dirEntry)
          if isDirectory
            then collect files (dirEntry : dirs') entries
            else collect (dirEntry : files) dirs' entries

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

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

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

    addEnv :: [([Char], [Char])] -> [([Char], [Char])]
addEnv [] = [([Char]
ldPath, [Char]
pathsString)]
    addEnv (([Char]
key, [Char]
value) : [([Char], [Char])]
xs)
      | [Char]
key [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
ldPath =
          if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
value
            then ([Char]
key, [Char]
pathsString) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: [([Char], [Char])]
xs
            else ([Char]
key, [Char]
value [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char
searchPathSeparator Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
pathsString)) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: [([Char], [Char])]
xs
      | Bool
otherwise = ([Char]
key, [Char]
value) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: [([Char], [Char])] -> [([Char], [Char])]
addEnv [([Char], [Char])]
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 -> IO Bool
moreRecentFile :: [Char] -> [Char] -> IO Bool
moreRecentFile [Char]
a [Char]
b = do
  exists <- [Char] -> IO Bool
doesFileExist [Char]
b
  if not exists
    then return True
    else do
      tb <- getModificationTime b
      ta <- getModificationTime a
      return (ta > tb)

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

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

-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
createDirectoryIfMissingVerbose
  :: Verbosity
  -> Bool
  -- ^ Create its parents too?
  -> FilePath
  -> IO ()
createDirectoryIfMissingVerbose :: Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
create_parents [Char]
path0
  | Bool
create_parents = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO ()
createDirs ([Char] -> [[Char]]
parents [Char]
path0)
  | Bool
otherwise = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO ()
createDirs (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
1 ([Char] -> [[Char]]
parents [Char]
path0))
  where
    parents :: [Char] -> [[Char]]
parents = [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
(</>) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitDirectories ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
normalise

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

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

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

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

-- | Given a relative path to a file, copy it to the given directory, preserving
-- the relative path and creating the parent directories if needed.
copyFileTo
  :: Verbosity
  -> FilePath
  -> FilePath
  -> IO ()
copyFileTo :: Verbosity -> [Char] -> [Char] -> IO ()
copyFileTo Verbosity
verbosity [Char]
dir [Char]
file =
  (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir target_7)
-> RelativePath Pkg 'File
-> IO ()
forall target.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir target)
-> RelativePath Pkg 'File
-> IO ()
copyFileToCwd
      Verbosity
verbosity
      Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
      ([Char] -> SymbolicPath Pkg ('Dir target_7)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
dir)
      ([Char] -> RelativePath Pkg 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
file)

-- | Given a relative path to a file, copy it to the given directory, preserving
-- the relative path and creating the parent directories if needed.
copyFileToCwd
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> SymbolicPath Pkg (Dir target)
  -> RelativePath Pkg File
  -> IO ()
copyFileToCwd :: forall target.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir target)
-> RelativePath Pkg 'File
-> IO ()
copyFileToCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir target)
dir RelativePath Pkg 'File
file = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let targetFile :: [Char]
targetFile = SymbolicPathX 'AllowAbsolute Pkg to_6 -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i (SymbolicPathX 'AllowAbsolute Pkg to_6 -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg to_6 -> [Char]
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir target)
dir SymbolicPath Pkg ('Dir target)
-> SymbolicPathX 'OnlyRelative target to_6
-> SymbolicPathX 'AllowAbsolute Pkg to_6
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Pkg 'File -> SymbolicPathX 'OnlyRelative target to_6
forall (allowAbsolute :: AllowAbsolute) from1 (to1 :: FileOrDir)
       from2 (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from1 to1
-> SymbolicPathX allowAbsolute from2 to2
unsafeCoerceSymbolicPath RelativePath Pkg 'File
file
  Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True ([Char] -> [Char]
takeDirectory [Char]
targetFile)
  Verbosity -> [Char] -> [Char] -> IO ()
installOrdinaryFile Verbosity
verbosity (RelativePath Pkg 'File -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i RelativePath Pkg 'File
file) [Char]
targetFile
  where
    i :: SymbolicPathX allowAbs Pkg to -> FilePath
    i :: forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbs Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir

-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith
  :: (Verbosity -> FilePath -> FilePath -> IO ())
  -> Verbosity
  -> FilePath
  -> [(FilePath, FilePath)]
  -> IO ()
copyFilesWith :: (Verbosity -> [Char] -> [Char] -> IO ())
-> Verbosity -> [Char] -> [([Char], [Char])] -> IO ()
copyFilesWith Verbosity -> [Char] -> [Char] -> IO ()
doCopy Verbosity
verbosity [Char]
targetDir [([Char], [Char])]
srcFiles = (HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO ()) -> IO ())
-> (HasCallStack => IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  -- Create parent directories for everything
  let dirs :: [[Char]]
dirs = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
targetDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</>) ([[Char]] -> [[Char]])
-> ([([Char], [Char])] -> [[Char]])
-> [([Char], [Char])]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
ordNub ([[Char]] -> [[Char]])
-> ([([Char], [Char])] -> [[Char]])
-> [([Char], [Char])]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
takeDirectory ([Char] -> [Char])
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ([([Char], [Char])] -> [[Char]]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [([Char], [Char])]
srcFiles
  ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True) [[Char]]
dirs

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

-- | A robust helper to remove an existing file, which does not throw
-- an exception if such file never existed, thus akin to removePathForcibly.
removeFileForcibly :: FilePath -> IO ()
removeFileForcibly :: [Char] -> IO ()
removeFileForcibly [Char]
fp = IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ([Char] -> IO ()
removeFile [Char]
fp) ((IOException -> IO ()) -> IO ())
-> (IOException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
  IOException
e
    -- If the file never existed in the first place, we are golden.
    | IOException -> Bool
isDoesNotExistError IOException
e -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- If we got a permission error, chances are that it's a read-only
    -- file on Windows. Removing read-only attribute ourselves requires
    -- reaching out for internal API, so instead of it we call 'removePathForcibly',
    -- which is a bit of overkill for a single file, but well.
    | IOException -> Bool
isPermissionError IOException
e -> [Char] -> IO ()
removePathForcibly [Char]
fp
    -- If device is busy, wait 1ms and give it another go.
    -- EBUSY from unlink(2) is mapped to UnsatisfiedConstraints.
    | IOException -> IOErrorType
ioeGetErrorType IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
GHC.UnsatisfiedConstraints -> do
        Int -> IO ()
threadDelay Int
1000
        [Char] -> IO ()
removeFile [Char]
fp
    -- Else we give up.
    | Bool
otherwise -> IOException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOException
e

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

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

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

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

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

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

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

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

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

-- | Use a temporary filename that doesn't already exist
withTempFile
  :: String
  -- ^ File name template. See 'openTempFile'.
  -> (FilePath -> Handle -> IO a)
  -> IO a
withTempFile :: forall a. [Char] -> ([Char] -> Handle -> IO a) -> IO a
withTempFile [Char]
template [Char] -> Handle -> IO a
f = (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
forall a.
[Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileCwd [Char]
template ((SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
 -> IO a)
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$
    \SymbolicPathX 'AllowAbsolute Pkg 'File
fp Handle
h -> [Char] -> Handle -> IO a
f (SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPathX 'AllowAbsolute Pkg 'File
fp) Handle
h

-- | Use a temporary filename that doesn't already exist.
withTempFileCwd
  :: String
  -- ^ File name template. See 'openTempFile'.
  -> (SymbolicPath Pkg File -> Handle -> IO a)
  -> IO a
withTempFileCwd :: forall a.
[Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileCwd = (HasCallStack =>
 [Char]
 -> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
 -> IO a)
-> [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack =>
  [Char]
  -> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
  -> IO a)
 -> [Char]
 -> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
 -> IO a)
-> (HasCallStack =>
    [Char]
    -> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
    -> IO a)
-> [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ TempFileOptions
-> [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
forall a.
TempFileOptions
-> [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileEx TempFileOptions
defaultTempFileOptions

-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
-- argument.
withTempFileEx
  :: forall a
   . TempFileOptions
  -> String
  -- ^ File name template. See 'openTempFile'.
  -> (SymbolicPath Pkg File -> Handle -> IO a)
  -> IO a
withTempFileEx :: forall a.
TempFileOptions
-> [Char]
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a)
-> IO a
withTempFileEx TempFileOptions
opts [Char]
template SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a
action = do
  tmp <- IO [Char]
getTemporaryDirectory
  withFrozenCallStack $
    Exception.bracket
      (openTempFile tmp template)
      ( \([Char]
name, Handle
handle) -> do
          Handle -> IO ()
hClose Handle
handle
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TempFileOptions -> Bool
optKeepTempFiles TempFileOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            () -> IO () -> IO ()
forall a. a -> IO a -> IO a
handleDoesNotExist () (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              [Char] -> IO ()
removeFile [Char]
name
      )
      (withLexicalCallStack (\([Char]
fn, Handle
h) -> SymbolicPathX 'AllowAbsolute Pkg 'File -> Handle -> IO a
action ([Char] -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
mkRelToPkg [Char]
tmp [Char]
fn) Handle
h))
  where
    mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File
    mkRelToPkg :: [Char] -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
mkRelToPkg [Char]
tmp [Char]
fp =
      [Char] -> SymbolicPathX 'AllowAbsolute Pkg ('Dir from_4)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
tmp SymbolicPathX 'AllowAbsolute Pkg ('Dir from_4)
-> SymbolicPathX 'OnlyRelative from_4 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative from_4 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char] -> [Char]
takeFileName [Char]
fp)

-- 'openTempFile' returns a path of the form @i tmpDir </> fn@, but we
-- want 'withTempFileEx' to return @tmpDir </> fn@. So we split off
-- the filename and add back the (un-interpreted) directory.
-- This assumes 'openTempFile' returns a filepath of the form
-- @inputDir </> fn@, where @fn@ does not contain any path separators.

-- | 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 "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
withTempDirectory
  :: FilePath
  -> String
  -> (FilePath -> IO a)
  -> IO a
withTempDirectory :: forall a. [Char] -> [Char] -> ([Char] -> IO a) -> IO a
withTempDirectory [Char]
targetDir [Char]
template [Char] -> IO a
f =
  (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1_3)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2_2) -> IO a)
-> IO a
forall tmpDir1 tmpDir2 a.
Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwd
      Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
      ([Char] -> SymbolicPath Pkg ('Dir tmpDir1_3)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
targetDir)
      [Char]
template
      ([Char] -> IO a
f ([Char] -> IO a)
-> (SymbolicPath Pkg ('Dir tmpDir2_2) -> [Char])
-> SymbolicPath Pkg ('Dir tmpDir2_2)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir tmpDir2_2) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath)

-- | 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 "src" "sdist." $ \tmpDir -> do ...
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
withTempDirectoryCwd
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ Working directory
  -> SymbolicPath Pkg (Dir tmpDir1)
  -> String
  -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)
  -> IO a
withTempDirectoryCwd :: forall tmpDir1 tmpDir2 a.
Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir tmpDir1)
targetDir [Char]
template SymbolicPath Pkg ('Dir tmpDir2) -> IO a
f =
  (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
forall a tmpDir1 tmpDir2.
TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx
      TempFileOptions
defaultTempFileOptions
      Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
      SymbolicPath Pkg ('Dir tmpDir1)
targetDir
      [Char]
template
      ((SymbolicPath Pkg ('Dir tmpDir2) -> HasCallStack => IO a)
-> WithCallStack (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack (\SymbolicPath Pkg ('Dir tmpDir2)
x -> SymbolicPath Pkg ('Dir tmpDir2) -> IO a
f SymbolicPath Pkg ('Dir tmpDir2)
x))

-- | A version of 'withTempDirectory' that additionally takes a
-- 'TempFileOptions' argument.
withTempDirectoryEx
  :: TempFileOptions
  -> FilePath
  -> String
  -> (FilePath -> IO a)
  -> IO a
withTempDirectoryEx :: forall a.
TempFileOptions -> [Char] -> [Char] -> ([Char] -> IO a) -> IO a
withTempDirectoryEx TempFileOptions
opts [Char]
targetDir [Char]
template [Char] -> IO a
f =
  (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1_1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2_0) -> IO a)
-> IO a
forall a tmpDir1 tmpDir2.
TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx TempFileOptions
opts Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing ([Char] -> SymbolicPath Pkg ('Dir tmpDir1_1)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
targetDir) [Char]
template ((SymbolicPath Pkg ('Dir tmpDir2_0) -> IO a) -> IO a)
-> (SymbolicPath Pkg ('Dir tmpDir2_0) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
      \SymbolicPath Pkg ('Dir tmpDir2_0)
fp -> [Char] -> IO a
f (SymbolicPath Pkg ('Dir tmpDir2_0) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg ('Dir tmpDir2_0)
fp)

-- | A version of 'withTempDirectoryCwd' that additionally takes a
-- 'TempFileOptions' argument.
withTempDirectoryCwdEx
  :: forall a tmpDir1 tmpDir2
   . TempFileOptions
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ Working directory
  -> SymbolicPath Pkg (Dir tmpDir1)
  -> String
  -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a)
  -> IO a
withTempDirectoryCwdEx :: forall a tmpDir1 tmpDir2.
TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> [Char]
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwdEx TempFileOptions
opts Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir tmpDir1)
targetDir [Char]
template SymbolicPath Pkg ('Dir tmpDir2) -> IO a
f =
  (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    IO [Char] -> ([Char] -> IO ()) -> ([Char] -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
      ([Char] -> [Char] -> IO [Char]
createTempDirectory (SymbolicPath Pkg ('Dir tmpDir1) -> [Char]
i SymbolicPath Pkg ('Dir tmpDir1)
targetDir) [Char]
template)
      ( \[Char]
tmpDirRelPath ->
          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
$
            [Char] -> IO ()
removePathForcibly (SymbolicPath Pkg ('Dir tmpDir1) -> [Char]
i SymbolicPath Pkg ('Dir tmpDir1)
targetDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
tmpDirRelPath)
      )
      (([Char] -> HasCallStack => IO a) -> WithCallStack ([Char] -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack (\[Char]
tmpDirRelPath -> SymbolicPath Pkg ('Dir tmpDir2) -> IO a
f (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> SymbolicPath Pkg ('Dir tmpDir2) -> IO a
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir tmpDir1)
targetDir SymbolicPath Pkg ('Dir tmpDir1)
-> SymbolicPathX 'OnlyRelative tmpDir1 ('Dir tmpDir2)
-> SymbolicPath Pkg ('Dir tmpDir2)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative tmpDir1 ('Dir tmpDir2)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
tmpDirRelPath))
  where
    i :: SymbolicPath Pkg ('Dir tmpDir1) -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path

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

-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
--
-- NB: Before Cabal-3.0 the file content was assumed to be
--     ASCII-representable. Since Cabal-3.0 the file is assumed to be
--     UTF-8 encoded.
rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()
rewriteFileEx :: Verbosity -> [Char] -> [Char] -> IO ()
rewriteFileEx Verbosity
verbosity [Char]
path =
  Verbosity -> [Char] -> ByteString -> IO ()
rewriteFileLBS Verbosity
verbosity [Char]
path (ByteString -> IO ()) -> ([Char] -> ByteString) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
toUTF8LBS

-- | Same as `rewriteFileEx` but for 'ByteString's.
rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO ()
rewriteFileLBS :: Verbosity -> [Char] -> ByteString -> IO ()
rewriteFileLBS Verbosity
verbosity [Char]
path ByteString
newContent =
  (IO () -> (IOException -> IO ()) -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IOException -> IO ()
mightNotExist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    existingContent <- Verbosity -> IO ByteString -> IO ByteString
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    _ <- evaluate (BS.length existingContent)
    unless (existingContent == newContent) $
      annotateIO verbosity $
        writeFileAtomic path newContent
  where
    mightNotExist :: IOException -> IO ()
mightNotExist IOException
e
      | IOException -> Bool
isDoesNotExistError IOException
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
$ [Char] -> ByteString -> IO ()
writeFileAtomic [Char]
path ByteString
newContent
      | Bool
otherwise =
          IOException -> IO ()
forall a. HasCallStack => IOException -> IO a
ioError IOException
e

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

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

-- | List of possible executable file extensions on the current build
-- platform.
exeExtensions :: [String]
exeExtensions :: [[Char]]
exeExtensions = case (Arch
buildArch, 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".
  --
  -- See also #10179.
  --
  -- Also we cannot actually run @.bat@ files as we do now, because of
  -- https://github.com/haskell/process/issues/140. If we detect one of those,
  -- we should record that the program is a script and run a @Process.shell@ instead
  -- of a @Process.proc@.
  (Arch
_, OS
Windows) -> [[Char]
"", [Char]
"exe"]
  (Arch
_, OS
Ghcjs) -> [[Char]
"", [Char]
"exe"]
  (Arch
Wasm32, OS
_) -> [[Char]
"", [Char]
"wasm"]
  (Arch, OS)
_ -> [[Char]
""]

-- ------------------------------------------------------------

-- * Finding the description file

-- ------------------------------------------------------------

-- | Package description file (/pkgname/@.cabal@) in the current
-- working directory.
defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File)
defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg 'File)
defaultPackageDescCwd Verbosity
verbosity = Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing

-- | Find a package description file in the given directory.  Looks for
--  @.cabal@ files.
findPackageDesc
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ package directory
  -> IO (Either CabalException (RelativePath Pkg File))
findPackageDesc :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (Either CabalException (RelativePath Pkg 'File))
findPackageDesc Maybe (SymbolicPath CWD ('Dir Pkg))
mbPkgDir =
  do
    let pkgDir :: [Char]
pkgDir = [Char]
-> (SymbolicPath CWD ('Dir Pkg) -> [Char])
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"." SymbolicPath CWD ('Dir Pkg) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbPkgDir
    files <- [Char] -> IO [[Char]]
listDirectory [Char]
pkgDir
    -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
    -- file we filter to exclude dirs and null base file names:
    cabalFiles <-
      filterM
        (doesFileExist . uncurry (</>))
        [ (pkgDir, file)
        | file <- files
        , let (name, ext) = splitExtension file
        , not (null name) && ext == ".cabal"
        ]
    case map snd cabalFiles of
      [] -> Either CabalException (RelativePath Pkg 'File)
-> IO (Either CabalException (RelativePath Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalException -> Either CabalException (RelativePath Pkg 'File)
forall a b. a -> Either a b
Left CabalException
NoDesc)
      [[Char]
cabalFile] -> Either CabalException (RelativePath Pkg 'File)
-> IO (Either CabalException (RelativePath Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePath Pkg 'File
-> Either CabalException (RelativePath Pkg 'File)
RelativePath Pkg 'File
-> Either CabalException (RelativePath Pkg 'File)
forall a b. b -> Either a b
Right (RelativePath Pkg 'File
 -> Either CabalException (RelativePath Pkg 'File))
-> RelativePath Pkg 'File
-> Either CabalException (RelativePath Pkg 'File)
forall a b. (a -> b) -> a -> b
$ [Char] -> RelativePath Pkg 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
cabalFile)
      [[Char]]
multiple -> Either CabalException (RelativePath Pkg 'File)
-> IO (Either CabalException (RelativePath Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalException -> Either CabalException (RelativePath Pkg 'File)
CabalException -> Either CabalException (RelativePath Pkg 'File)
forall a b. a -> Either a b
Left (CabalException -> Either CabalException (RelativePath Pkg 'File))
-> CabalException -> Either CabalException (RelativePath Pkg 'File)
forall a b. (a -> b) -> a -> b
$ [[Char]] -> CabalException
MultiDesc [[Char]]
multiple)

-- | Like 'findPackageDesc', but calls 'die' in case of error.
tryFindPackageDesc
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ directory in which to look
  -> IO (RelativePath Pkg File)
tryFindPackageDesc :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
dir =
  (CabalException -> IO (RelativePath Pkg 'File))
-> (RelativePath Pkg 'File -> IO (RelativePath Pkg 'File))
-> Either CabalException (RelativePath Pkg 'File)
-> IO (RelativePath Pkg 'File)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> CabalException -> IO (RelativePath Pkg 'File)
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity) RelativePath Pkg 'File -> IO (RelativePath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CabalException (RelativePath Pkg 'File)
 -> IO (RelativePath Pkg 'File))
-> IO (Either CabalException (RelativePath Pkg 'File))
-> IO (RelativePath Pkg 'File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (Either CabalException (RelativePath Pkg 'File))
findPackageDesc Maybe (SymbolicPath CWD ('Dir Pkg))
dir

-- | Find auxiliary package information in the given directory.
--  Looks for @.buildinfo@ files.
findHookedPackageDesc
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -- ^ Working directory
  -> SymbolicPath Pkg (Dir Build)
  -- ^ Directory to search
  -> IO (Maybe (SymbolicPath Pkg File))
  -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present
findHookedPackageDesc :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
-> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File))
findHookedPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
dir = do
  files <- [Char] -> IO [[Char]]
listDirectory ([Char] -> IO [[Char]]) -> [Char] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
dir
  buildInfoFiles <-
    filterM
      (doesFileExist . interpretSymbolicPath mbWorkDir)
      [ dir </> makeRelativePathEx file
      | file <- files
      , let (name, ext) = splitExtension file
      , not (null name) && ext == buildInfoExt
      ]
  case buildInfoFiles of
    [] -> Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. Maybe a
Nothing
    [SymbolicPathX 'AllowAbsolute Pkg 'File
f] -> Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPathX 'AllowAbsolute Pkg 'File
-> Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. a -> Maybe a
Just SymbolicPathX 'AllowAbsolute Pkg 'File
f)
    [SymbolicPathX 'AllowAbsolute Pkg 'File]
_ -> Verbosity
-> CabalException
-> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File))
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException
 -> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)))
-> CabalException
-> IO (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File))
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalException
MultipleFilesWithExtension [Char]
buildInfoExt

buildInfoExt :: String
buildInfoExt :: [Char]
buildInfoExt = [Char]
".buildinfo"

-- | @stripCommonPrefix xs ys@ gives you @ys@ without the common prefix with @xs@.
stripCommonPrefix :: String -> String -> String
stripCommonPrefix :: [Char] -> [Char] -> [Char]
stripCommonPrefix (Char
x : [Char]
xs) (Char
y : [Char]
ys)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y = [Char] -> [Char] -> [Char]
stripCommonPrefix [Char]
xs [Char]
ys
  | Bool
otherwise = Char
y Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
ys
stripCommonPrefix [Char]
_ [Char]
ys = [Char]
ys