{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE BangPatterns #-}
module Distribution.Simple.Utils (
cabalVersion,
dieNoVerbosity,
die', dieWithLocation',
dieNoWrap,
topHandler, topHandlerWith,
warn,
notice, noticeNoWrap, noticeDoc,
setupMessage,
info, infoNoWrap,
debug, debugNoWrap,
chattyTry,
annotateIO,
printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
withOutputMarker,
handleDoesNotExist,
rawSystemExit,
rawSystemExitCode,
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
rawSystemIOWithEnv,
createProcessWithEnv,
maybeExit,
xargs,
findProgramVersion,
IOData(..),
IODataMode(..),
createDirectoryIfMissingVerbose,
copyFileVerbose,
copyFiles,
copyFileTo,
installOrdinaryFile,
installExecutableFile,
installMaybeExecutableFile,
installOrdinaryFiles,
installExecutableFiles,
installMaybeExecutableFiles,
installDirectoryContents,
copyDirectoryRecursive,
doesExecutableExist,
setFileOrdinary,
setFileExecutable,
currentDir,
shortRelativePath,
dropExeExtension,
exeExtensions,
findFileEx,
findFirstFile,
findFileWithExtension,
findFileWithExtension',
findAllFilesWithExtension,
findModuleFileEx,
findModuleFilesEx,
getDirectoryContentsRecursive,
isInSearchPath,
addLibraryPath,
moreRecentFile,
existsAndIsMoreRecentThan,
TempFileOptions(..), defaultTempFileOptions,
withTempFile, withTempFileEx,
withTempDirectory, withTempDirectoryEx,
createTempDirectory,
defaultPackageDesc,
findPackageDesc,
tryFindPackageDesc,
findHookedPackageDesc,
withFileContents,
writeFileAtomic,
rewriteFileEx,
fromUTF8BS,
fromUTF8LBS,
toUTF8BS,
toUTF8LBS,
readUTF8File,
withUTF8FileContents,
writeUTF8File,
normaliseLineEndings,
ignoreBOM,
dropWhileEndLE,
takeWhileEndLE,
equating,
comparing,
isInfixOf,
intercalate,
lowercase,
listUnion,
listUnionRight,
ordNub,
ordNubBy,
ordNubRight,
safeTail,
unintersperse,
wrapText,
wrapLine,
isAbsoluteOnAnyPlatform,
isRelativeOnAnyPlatform,
findFile,
findModuleFile,
findModuleFiles,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic
import Distribution.Utils.IOData (IOData(..), IODataMode(..))
import qualified Distribution.Utils.IOData as IOData
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
import Distribution.Compat.CopyFile
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Exception
import Distribution.Compat.Stack
import Distribution.Verbosity
import Distribution.Types.PackageId
#if __GLASGOW_HASKELL__ < 711
#ifdef VERSION_base
#define BOOTSTRAPPED_CABAL 1
#endif
#else
#ifdef CURRENT_PACKAGE_KEY
#define BOOTSTRAPPED_CABAL 1
#endif
#endif
#ifdef BOOTSTRAPPED_CABAL
import qualified Paths_Cabal (version)
#endif
import Distribution.Pretty
import Distribution.Parsec
import Control.Concurrent.MVar
( newEmptyMVar, putMVar, takeMVar )
import Data.Typeable
( cast )
import qualified Data.ByteString.Lazy as BS
import System.Directory
( Permissions(executable), getDirectoryContents, getPermissions
, doesDirectoryExist, doesFileExist, removeFile
, getModificationTime, createDirectory, removeDirectoryRecursive )
import System.Environment
( getProgName )
import System.Exit
( exitWith, ExitCode(..) )
import System.FilePath
( normalise, (</>), (<.>)
, getSearchPath, joinPath, takeDirectory, splitExtension
, splitDirectories, searchPathSeparator )
import System.IO
( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush
, hClose, hSetBuffering, BufferMode(..) )
import System.IO.Error
import System.IO.Unsafe
( unsafeInterleaveIO )
import qualified Control.Exception as Exception
import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Control.Exception (IOException, evaluate, throwIO)
import Control.Concurrent (forkIO)
import Numeric (showFFloat)
import qualified System.Process as Process
( CreateProcess(..), StdStream(..), proc)
import System.Process
( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
, showCommandForUser, waitForProcess)
import qualified Text.PrettyPrint as Disp
cabalVersion :: Version
#if defined(BOOTSTRAPPED_CABAL)
cabalVersion :: Version
cabalVersion = Version -> Version
mkVersion' Version
Paths_Cabal.version
#elif defined(CABAL_VERSION)
cabalVersion = mkVersion [CABAL_VERSION]
#else
cabalVersion = mkVersion [1,9999]
#endif
dieNoVerbosity :: String -> IO a
dieNoVerbosity :: String -> IO a
dieNoVerbosity msg :: String
msg
= IOError -> IO a
forall a. IOError -> IO a
ioError (String -> IOError
userError String
msg)
where
CallStack
_ = CallStack
HasCallStack => CallStack
callStack
ioeSetVerbatim :: IOError -> IOError
ioeSetVerbatim :: IOError -> IOError
ioeSetVerbatim e :: IOError
e = IOError -> String -> IOError
ioeSetLocation IOError
e "dieVerbatim"
ioeGetVerbatim :: IOError -> Bool
ioeGetVerbatim :: IOError -> Bool
ioeGetVerbatim e :: IOError
e = IOError -> String
ioeGetLocation IOError
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "dieVerbatim"
verbatimUserError :: String -> IOError
verbatimUserError :: String -> IOError
verbatimUserError = IOError -> IOError
ioeSetVerbatim (IOError -> IOError) -> (String -> IOError) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError
dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
dieWithLocation' :: Verbosity -> String -> Maybe Int -> String -> IO a
dieWithLocation' verbosity :: Verbosity
verbosity filename :: String
filename mb_lineno :: Maybe Int
mb_lineno msg :: String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
String
pname <- IO String
getProgName
IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
(String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ (case Maybe Int
mb_lineno of
Just lineno :: Int
lineno -> ":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
lineno
Nothing -> "") String -> String -> String
forall a. [a] -> [a] -> [a]
++
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
die' :: Verbosity -> String -> IO a
die' :: Verbosity -> String -> IO a
die' verbosity :: Verbosity
verbosity msg :: String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
String
pname <- IO String
getProgName
IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
(String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap verbosity :: Verbosity
verbosity msg :: String
msg = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> (String -> IOError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
verbatimUserError
(String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
AlwaysMark TraceWhen
VerboseTrace Verbosity
verbosity
(String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
msg
annotateIO :: Verbosity -> IO a -> IO a
annotateIO :: Verbosity -> IO a -> IO a
annotateIO verbosity :: Verbosity
verbosity act :: IO a
act = do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
(IOError -> IOError) -> IO a -> IO a
forall a. (IOError -> IOError) -> IO a -> IO a
modifyIOError (POSIXTime -> IOError -> IOError
f POSIXTime
ts) IO a
IO a
act
where
f :: POSIXTime -> IOError -> IOError
f ts :: POSIXTime
ts ioe :: IOError
ioe = IOError -> String -> IOError
ioeSetErrorString IOError
ioe
(String -> IOError) -> (String -> String) -> String -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
VerboseTrace Verbosity
verbosity
(String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ IOError -> String
ioeGetErrorString IOError
ioe
{-# NOINLINE topHandlerWith #-}
topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
topHandlerWith :: (SomeException -> IO a) -> IO a -> IO a
topHandlerWith cont :: SomeException -> IO a
cont prog :: IO a
prog = do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
Exception.catches IO a
IO a
prog [
(AsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler AsyncException -> IO a
rethrowAsyncExceptions
, (ExitCode -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler ExitCode -> IO a
rethrowExitStatus
, (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler SomeException -> IO a
handle
]
where
rethrowAsyncExceptions :: Exception.AsyncException -> NoCallStackIO a
rethrowAsyncExceptions :: AsyncException -> IO a
rethrowAsyncExceptions a :: AsyncException
a = AsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO AsyncException
a
rethrowExitStatus :: ExitCode -> NoCallStackIO a
rethrowExitStatus :: ExitCode -> IO a
rethrowExitStatus = ExitCode -> IO a
forall e a. Exception e => e -> IO a
throwIO
handle :: Exception.SomeException -> NoCallStackIO a
handle :: SomeException -> IO a
handle se :: SomeException
se = do
Handle -> IO ()
hFlush Handle
stdout
String
pname <- IO String
getProgName
Handle -> String -> IO ()
hPutStr Handle
stderr (String -> SomeException -> String
message String
pname SomeException
se)
SomeException -> IO a
cont SomeException
se
message :: String -> Exception.SomeException -> String
message :: String -> SomeException -> String
message pname :: String
pname (Exception.SomeException se :: e
se) =
case e -> Maybe IOError
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
se :: Maybe Exception.IOException of
Just ioe :: IOError
ioe
| IOError -> Bool
ioeGetVerbatim IOError
ioe ->
IOError -> String
ioeGetErrorString IOError
ioe String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
| IOError -> Bool
isUserError IOError
ioe ->
let file :: String
file = case IOError -> Maybe String
ioeGetFileName IOError
ioe of
Nothing -> ""
Just path :: String
path -> String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
location String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": "
location :: String
location = case IOError -> String
ioeGetLocation IOError
ioe of
l :: String
l@(n :: Char
n:_) | Char -> Bool
isDigit Char
n -> ':' Char -> String -> String
forall a. a -> [a] -> [a]
: String
l
_ -> ""
detail :: String
detail = IOError -> String
ioeGetErrorString IOError
ioe
in String -> String
wrapText (String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
detail)
_ ->
e -> String
forall e. Exception e => e -> String
displaySomeException e
se String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
displaySomeException :: Exception.Exception e => e -> String
displaySomeException :: e -> String
displaySomeException se :: e
se =
#if __GLASGOW_HASKELL__ < 710
show se
#else
e -> String
forall e. Exception e => e -> String
Exception.displayException e
se
#endif
topHandler :: IO a -> IO a
topHandler :: IO a -> IO a
topHandler prog :: IO a
prog = (SomeException -> IO a) -> IO a -> IO a
forall a. (SomeException -> IO a) -> IO a -> IO a
topHandlerWith (IO a -> SomeException -> IO a
forall a b. a -> b -> a
const (IO a -> SomeException -> IO a) -> IO a -> SomeException -> IO a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)) IO a
prog
warn :: Verbosity -> String -> IO ()
warn :: Verbosity -> String -> IO ()
warn verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> IO ()
hFlush Handle
stdout
Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
notice :: Verbosity -> String -> IO ()
notice :: Verbosity -> String -> IO ()
notice verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
noticeDoc :: Verbosity -> Disp.Doc -> IO ()
noticeDoc :: Verbosity -> Doc -> IO ()
noticeDoc verbosity :: Verbosity
verbosity msg :: Doc
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (Doc -> String) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NormalMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> String) -> (Doc -> String) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Doc -> String
Disp.renderStyle Style
defaultStyle (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
msg
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity :: Verbosity
verbosity msg :: String
msg pkgid :: PackageIdentifier
pkgid = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ' 'Char -> String -> String
forall a. a -> [a] -> [a]
: PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ "...")
info :: Verbosity -> String -> IO ()
info :: Verbosity -> String -> IO ()
info verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
debug :: Verbosity -> String -> IO ()
debug :: Verbosity -> String -> IO ()
debug verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> String
wrapTextVerbosity Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
Handle -> IO ()
hFlush Handle
stdout
debugNoWrap :: Verbosity -> String -> IO ()
debugNoWrap :: Verbosity -> String -> IO ()
debugNoWrap verbosity :: Verbosity
verbosity msg :: String
msg = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
ts <- IO POSIXTime
getPOSIXTime
Handle -> String -> IO ()
hPutStr Handle
stdout (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack
(POSIXTime
-> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata POSIXTime
ts MarkWhen
NeverMark TraceWhen
FlagTrace Verbosity
verbosity
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg
Handle -> IO ()
hFlush Handle
stdout
chattyTry :: String
-> IO ()
-> IO ()
chattyTry :: String -> IO () -> IO ()
chattyTry desc :: String
desc action :: IO ()
action =
IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catchIO IO ()
IO ()
action ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \exception :: IOError
exception ->
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Error while " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
exception
handleDoesNotExist :: a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist :: a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist e :: a
e =
(IOError -> Maybe IOError)
-> (IOError -> NoCallStackIO a)
-> NoCallStackIO a
-> NoCallStackIO a
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
Exception.handleJust
(\ioe :: IOError
ioe -> if IOError -> Bool
isDoesNotExistError IOError
ioe then IOError -> Maybe IOError
forall a. a -> Maybe a
Just IOError
ioe else Maybe IOError
forall a. Maybe a
Nothing)
(\_ -> a -> NoCallStackIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
e)
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity verb :: Verbosity
verb
| Verbosity -> Bool
isVerboseNoWrap Verbosity
verb = String -> String
withTrailingNewline
| Bool
otherwise = String -> String
withTrailingNewline (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
wrapText
withTimestamp :: Verbosity -> POSIXTime -> String -> String
withTimestamp :: Verbosity -> POSIXTime -> String -> String
withTimestamp v :: Verbosity
v ts :: POSIXTime
ts msg :: String
msg
| Verbosity -> Bool
isVerboseTimestamp Verbosity
v = String
msg'
| Bool
otherwise = String
msg
where
msg' :: String
msg' = case String -> [String]
lines String
msg of
[] -> String -> String
tsstr "\n"
l1 :: String
l1:rest :: [String]
rest -> [String] -> String
unlines (String -> String
tsstr (' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
l1) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
contpfxString -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
rest)
tsstr :: String -> String
tsstr = Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just 3) (POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
ts :: Double)
contpfx :: String
contpfx = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> String
tsstr " ")) ' '
withOutputMarker :: Verbosity -> String -> String
withOutputMarker :: Verbosity -> String -> String
withOutputMarker v :: Verbosity
v xs :: String
xs | Bool -> Bool
not (Verbosity -> Bool
isVerboseMarkOutput Verbosity
v) = String
xs
withOutputMarker _ "" = ""
withOutputMarker _ xs :: String
xs =
"-----BEGIN CABAL OUTPUT-----\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> String
withTrailingNewline String
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++
"-----END CABAL OUTPUT-----\n"
withTrailingNewline :: String -> String
withTrailingNewline :: String -> String
withTrailingNewline "" = ""
withTrailingNewline (x :: Char
x:xs :: String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> String -> String
go Char
x String
xs
where
go :: Char -> String -> String
go _ (c :: Char
c:cs :: String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> String -> String
go Char
c String
cs
go '\n' "" = ""
go _ "" = "\n"
withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)
withCallStackPrefix :: TraceWhen -> Verbosity -> String -> String
withCallStackPrefix tracer :: TraceWhen
tracer verbosity :: Verbosity
verbosity s :: String
s = (HasCallStack => String) -> String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String) -> String)
-> (HasCallStack => String) -> String
forall a b. (a -> b) -> a -> b
$
(if Verbosity -> Bool
isVerboseCallSite Verbosity
verbosity
then String
HasCallStack => String
parentSrcLocPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++
if Verbosity -> Bool
isVerboseMarkOutput Verbosity
verbosity
then "\n"
else ""
else "") String -> String -> String
forall a. [a] -> [a] -> [a]
++
(case Verbosity -> TraceWhen -> Maybe String
traceWhen Verbosity
verbosity TraceWhen
tracer of
Just pre :: String
pre -> String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
Nothing -> "") String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
s
data TraceWhen
= AlwaysTrace
| VerboseTrace
| FlagTrace
deriving (TraceWhen -> TraceWhen -> Bool
(TraceWhen -> TraceWhen -> Bool)
-> (TraceWhen -> TraceWhen -> Bool) -> Eq TraceWhen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceWhen -> TraceWhen -> Bool
$c/= :: TraceWhen -> TraceWhen -> Bool
== :: TraceWhen -> TraceWhen -> Bool
$c== :: TraceWhen -> TraceWhen -> Bool
Eq)
traceWhen :: Verbosity -> TraceWhen -> Maybe String
traceWhen :: Verbosity -> TraceWhen -> Maybe String
traceWhen _ AlwaysTrace = String -> Maybe String
forall a. a -> Maybe a
Just ""
traceWhen v :: Verbosity
v VerboseTrace | Verbosity
v Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose = String -> Maybe String
forall a. a -> Maybe a
Just ""
traceWhen v :: Verbosity
v FlagTrace | Verbosity -> Bool
isVerboseCallStack Verbosity
v = String -> Maybe String
forall a. a -> Maybe a
Just "----\n"
traceWhen _ _ = Maybe String
forall a. Maybe a
Nothing
data MarkWhen = AlwaysMark | NormalMark | NeverMark
withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
withMetadata :: POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String
withMetadata ts :: POSIXTime
ts marker :: MarkWhen
marker tracer :: TraceWhen
tracer verbosity :: Verbosity
verbosity x :: String
x = (HasCallStack => String) -> String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String) -> String)
-> (HasCallStack => String) -> String
forall a b. (a -> b) -> a -> b
$
String -> String
withTrailingNewline
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithCallStack (TraceWhen -> Verbosity -> String -> String)
TraceWhen -> Verbosity -> String -> String
withCallStackPrefix TraceWhen
tracer Verbosity
verbosity
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case MarkWhen
marker of
AlwaysMark -> Verbosity -> String -> String
withOutputMarker Verbosity
verbosity
NormalMark | Bool -> Bool
not (Verbosity -> Bool
isVerboseQuiet Verbosity
verbosity)
-> Verbosity -> String -> String
withOutputMarker Verbosity
verbosity
| Bool
otherwise
-> String -> String
forall a. a -> a
id
NeverMark -> String -> String
forall a. a -> a
id)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
clearMarkers
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> POSIXTime -> String -> String
withTimestamp Verbosity
verbosity POSIXTime
ts
(String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
x
clearMarkers :: String -> String
clearMarkers :: String -> String
clearMarkers s :: String
s = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isMarker ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
where
isMarker :: String -> Bool
isMarker "-----BEGIN CABAL OUTPUT-----" = Bool
False
isMarker "-----END CABAL OUTPUT-----" = Bool
False
isMarker _ = Bool
True
maybeExit :: IO ExitCode -> IO ()
maybeExit :: IO ExitCode -> IO ()
maybeExit cmd :: IO ExitCode
cmd = do
ExitCode
res <- IO ExitCode
IO ExitCode
cmd
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
res ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
res
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs :: Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
printRawCommandAndArgsAndEnv :: Verbosity
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args mcwd :: Maybe String
mcwd menv :: Maybe [(String, String)]
menv = do
case Maybe [(String, String)]
menv of
Just env :: [(String, String)]
env -> Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity ("Environment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
forall a. Show a => a -> String
show [(String, String)]
env)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Maybe String
mcwd of
Just cwd :: String
cwd -> Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity ("Working directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
cwd)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Verbosity -> String -> IO ()
infoNoWrap Verbosity
verbosity (String -> [String] -> String
showCommandForUser String
path [String]
args)
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit :: Verbosity -> String -> [String] -> IO ()
rawSystemExit verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args
Handle -> IO ()
hFlush Handle
stdout
ExitCode
exitcode <- String -> [String] -> IO ExitCode
rawSystem String
path [String]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitcode
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
rawSystemExitCode :: Verbosity -> String -> [String] -> IO ExitCode
rawSystemExitCode verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args = IO ExitCode -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args
Handle -> IO ()
hFlush Handle
stdout
ExitCode
exitcode <- String -> [String] -> IO ExitCode
rawSystem String
path [String]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode
rawSystemExitWithEnv :: Verbosity
-> FilePath
-> [String]
-> [(String, String)]
-> IO ()
rawSystemExitWithEnv :: Verbosity -> String -> [String] -> [(String, String)] -> IO ()
rawSystemExitWithEnv verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args env :: [(String, String)]
env = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
forall a. Maybe a
Nothing ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
env)
Handle -> IO ()
hFlush Handle
stdout
(_,_,_,ph :: ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
(String -> [String] -> CreateProcess
Process.proc String
path [String]
args) { env :: Maybe [(String, String)]
Process.env = ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
env)
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
, delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True
#endif
#endif
}
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitcode
rawSystemIOWithEnv :: Verbosity
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args mcwd :: Maybe String
mcwd menv :: Maybe [(String, String)]
menv inp :: Maybe Handle
inp out :: Maybe Handle
out err :: Maybe Handle
err = IO ExitCode -> IO ExitCode
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
(_,_,_,ph :: ProcessHandle
ph) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv
(Maybe Handle -> StdStream
mbToStd Maybe Handle
inp) (Maybe Handle -> StdStream
mbToStd Maybe Handle
out) (Maybe Handle -> StdStream
mbToStd Maybe Handle
err)
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode
where
mbToStd :: Maybe Handle -> Process.StdStream
mbToStd :: Maybe Handle -> StdStream
mbToStd = StdStream -> (Handle -> StdStream) -> Maybe Handle -> StdStream
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
Process.Inherit Handle -> StdStream
Process.UseHandle
createProcessWithEnv ::
Verbosity
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> Process.StdStream
-> Process.StdStream
-> Process.StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)
createProcessWithEnv :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessWithEnv verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args mcwd :: Maybe String
mcwd menv :: Maybe [(String, String)]
menv inp :: StdStream
inp out :: StdStream
out err :: StdStream
err = IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ do
Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
printRawCommandAndArgsAndEnv Verbosity
verbosity String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv
Handle -> IO ()
hFlush Handle
stdout
(inp' :: Maybe Handle
inp', out' :: Maybe Handle
out', err' :: Maybe Handle
err', ph :: ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
(String -> [String] -> CreateProcess
Process.proc String
path [String]
args) {
cwd :: Maybe String
Process.cwd = Maybe String
mcwd
, env :: Maybe [(String, String)]
Process.env = Maybe [(String, String)]
menv
, std_in :: StdStream
Process.std_in = StdStream
inp
, std_out :: StdStream
Process.std_out = StdStream
out
, std_err :: StdStream
Process.std_err = StdStream
err
#ifdef MIN_VERSION_process
#if MIN_VERSION_process(1,2,0)
, delegate_ctlc :: Bool
Process.delegate_ctlc = Bool
True
#endif
#endif
}
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
inp', Maybe Handle
out', Maybe Handle
err', ProcessHandle
ph)
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout :: Verbosity -> String -> [String] -> IO String
rawSystemStdout verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args = IO String -> IO String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ do
(IODataText output :: String
output, errors :: String
errors, exitCode :: ExitCode
exitCode) <- Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, String, ExitCode)
rawSystemStdInOut Verbosity
verbosity String
path [String]
args
Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
Maybe IOData
forall a. Maybe a
Nothing IODataMode
IODataModeText
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
errors
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
output
rawSystemStdInOut :: Verbosity
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, String, ExitCode)
rawSystemStdInOut :: Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe IOData
-> IODataMode
-> IO (IOData, String, ExitCode)
rawSystemStdInOut verbosity :: Verbosity
verbosity path :: String
path args :: [String]
args mcwd :: Maybe String
mcwd menv :: Maybe [(String, String)]
menv input :: Maybe IOData
input outputMode :: IODataMode
outputMode = IO (IOData, String, ExitCode) -> IO (IOData, String, ExitCode)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (IOData, String, ExitCode) -> IO (IOData, String, ExitCode))
-> IO (IOData, String, ExitCode) -> IO (IOData, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> [String] -> IO ()
printRawCommandAndArgs Verbosity
verbosity String
path [String]
args
IO (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> IO ())
-> ((Handle, Handle, Handle, ProcessHandle)
-> IO (IOData, String, ExitCode))
-> IO (IOData, String, ExitCode)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
path [String]
args Maybe String
mcwd Maybe [(String, String)]
menv)
(\(inh :: Handle
inh,outh :: Handle
outh,errh :: Handle
errh,_) -> Handle -> IO ()
hClose Handle
inh IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
outh IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
errh)
(((Handle, Handle, Handle, ProcessHandle)
-> IO (IOData, String, ExitCode))
-> IO (IOData, String, ExitCode))
-> ((Handle, Handle, Handle, ProcessHandle)
-> IO (IOData, String, ExitCode))
-> IO (IOData, String, ExitCode)
forall a b. (a -> b) -> a -> b
$ \(inh :: Handle
inh,outh :: Handle
outh,errh :: Handle
errh,pid :: ProcessHandle
pid) -> do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
errh Bool
False
String
err <- Handle -> IO String
hGetContents Handle
errh
IOData
out <- Handle -> IODataMode -> IO IOData
IOData.hGetContents Handle
outh IODataMode
outputMode
MVar (Either IOError ())
mv <- IO (MVar (Either IOError ()))
forall a. IO (MVar a)
newEmptyMVar
let force :: a -> IO ()
force str :: a
str = do
Either IOError ()
mberr <- IO () -> IO (Either IOError ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (() -> IO ()
forall a. a -> IO a
evaluate (a -> ()
forall a. NFData a => a -> ()
rnf a
str) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
MVar (Either IOError ()) -> Either IOError () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either IOError ())
mv (Either IOError ()
mberr :: Either IOError ())
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IOData -> IO ()
forall a. NFData a => a -> IO ()
force IOData
out
ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. NFData a => a -> IO ()
force String
err
case Maybe IOData
input of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just inputData :: IOData
inputData -> do
Handle -> IOData -> IO ()
IOData.hPutContents Handle
inh IOData
inputData
Either IOError ()
mberr1 <- MVar (Either IOError ()) -> IO (Either IOError ())
forall a. MVar a -> IO a
takeMVar MVar (Either IOError ())
mv
Either IOError ()
mberr2 <- MVar (Either IOError ()) -> IO (Either IOError ())
forall a. MVar a -> IO a
takeMVar MVar (Either IOError ())
mv
ExitCode
exitcode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
exitcode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " returned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
exitcode
String -> String -> String
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
err then "" else
" with error message:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
String -> String -> String
forall a. [a] -> [a] -> [a]
++ case Maybe IOData
input of
Nothing -> ""
Just d :: IOData
d | IOData -> Bool
IOData.null IOData
d -> ""
Just (IODataText inp :: String
inp) -> "\nstdin input:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inp
Just (IODataBinary inp :: ByteString
inp) -> "\nstdin input (binary):\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
inp
Either IOError () -> IO ()
reportOutputIOError Either IOError ()
mberr1
Either IOError () -> IO ()
reportOutputIOError Either IOError ()
mberr2
(IOData, String, ExitCode) -> IO (IOData, String, ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (IOData
out, String
err, ExitCode
exitcode)
where
reportOutputIOError :: Either IOError () -> NoCallStackIO ()
reportOutputIOError :: Either IOError () -> IO ()
reportOutputIOError =
(IOError -> IO ()) -> (() -> IO ()) -> Either IOError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\e :: IOError
e -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOError -> String -> IOError
ioeSetFileName IOError
e ("output of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path)))
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return
findProgramVersion :: String
-> (String -> String)
-> Verbosity
-> FilePath
-> IO (Maybe Version)
findProgramVersion :: String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion versionArg :: String
versionArg selectVersion :: String -> String
selectVersion verbosity :: Verbosity
verbosity path :: String
path = IO (Maybe Version) -> IO (Maybe Version)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO (Maybe Version) -> IO (Maybe Version))
-> IO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ do
String
str <- Verbosity -> String -> [String] -> IO String
rawSystemStdout Verbosity
verbosity String
path [String
versionArg]
IO String -> (IOError -> IO String) -> IO String
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` (\_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "")
IO String -> (ExitCode -> IO String) -> IO String
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "")
let version :: Maybe Version
version :: Maybe Version
version = String -> Maybe Version
forall a. Parsec a => String -> Maybe a
simpleParsec (String -> String
selectVersion String
str)
case Maybe Version
version of
Nothing -> Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "cannot determine version of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " :\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str
Just v :: Version
v -> Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
v
Maybe Version -> IO (Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Version
version
xargs :: Int -> ([String] -> IO ())
-> [String] -> [String] -> IO ()
xargs :: Int -> ([String] -> IO ()) -> [String] -> [String] -> IO ()
xargs maxSize :: Int
maxSize rawSystemFun :: [String] -> IO ()
rawSystemFun fixedArgs :: [String]
fixedArgs bigArgs :: [String]
bigArgs =
let fixedArgSize :: Int
fixedArgSize = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fixedArgs) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
fixedArgs
chunkSize :: Int
chunkSize = Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fixedArgSize
in ([String] -> IO ()) -> [[String]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ([String] -> IO ()
[String] -> IO ()
rawSystemFun ([String] -> IO ()) -> ([String] -> [String]) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
fixedArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++)) (Int -> [String] -> [[String]]
forall (t :: * -> *) a. Foldable t => Int -> [t a] -> [[t a]]
chunks Int
chunkSize [String]
bigArgs)
where chunks :: Int -> [t a] -> [[t a]]
chunks len :: Int
len = ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]])
-> ([t a] -> Maybe ([t a], [t a])) -> [t a] -> [[t a]]
forall a b. (a -> b) -> a -> b
$ \s :: [t a]
s ->
if [t a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [t a]
s then Maybe ([t a], [t a])
forall a. Maybe a
Nothing
else ([t a], [t a]) -> Maybe ([t a], [t a])
forall a. a -> Maybe a
Just ([t a] -> Int -> [t a] -> ([t a], [t a])
forall (t :: * -> *) a.
Foldable t =>
[t a] -> Int -> [t a] -> ([t a], [t a])
chunk [] Int
len [t a]
s)
chunk :: [t a] -> Int -> [t a] -> ([t a], [t a])
chunk acc :: [t a]
acc _ [] = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc,[])
chunk acc :: [t a]
acc len :: Int
len (s :: t a
s:ss :: [t a]
ss)
| Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = [t a] -> Int -> [t a] -> ([t a], [t a])
chunk (t a
st a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
acc) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len'Int -> Int -> Int
forall a. Num a => a -> a -> a
-1) [t a]
ss
| Bool
otherwise = ([t a] -> [t a]
forall a. [a] -> [a]
reverse [t a]
acc, t a
st a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
ss)
where len' :: Int
len' = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
s
{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findFile :: [FilePath]
-> FilePath
-> IO FilePath
findFile :: [String] -> String -> IO String
findFile = Verbosity -> [String] -> String -> IO String
findFileEx Verbosity
normal
findFileEx :: Verbosity
-> [FilePath]
-> FilePath
-> IO FilePath
findFileEx :: Verbosity -> [String] -> String -> IO String
findFileEx verbosity :: Verbosity
verbosity searchPath :: [String]
searchPath fileName :: String
fileName =
(String -> String) -> [String] -> NoCallStackIO (Maybe String)
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile String -> String
forall a. a -> a
id
[ String
path String -> String -> String
</> String
fileName
| String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath]
NoCallStackIO (Maybe String)
-> (Maybe String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
fileName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " doesn't exist") String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return
findFileWithExtension :: [String]
-> [FilePath]
-> FilePath
-> NoCallStackIO (Maybe FilePath)
findFileWithExtension :: [String] -> [String] -> String -> NoCallStackIO (Maybe String)
findFileWithExtension extensions :: [String]
extensions searchPath :: [String]
searchPath baseName :: String
baseName =
(String -> String) -> [String] -> NoCallStackIO (Maybe String)
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile String -> String
forall a. a -> a
id
[ String
path String -> String -> String
</> String
baseName String -> String -> String
<.> String
ext
| String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
, String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
extensions ]
findAllFilesWithExtension :: [String]
-> [FilePath]
-> FilePath
-> NoCallStackIO [FilePath]
findAllFilesWithExtension :: [String] -> [String] -> String -> NoCallStackIO [String]
findAllFilesWithExtension extensions :: [String]
extensions searchPath :: [String]
searchPath basename :: String
basename =
(String -> String) -> [String] -> NoCallStackIO [String]
forall a. (a -> String) -> [a] -> NoCallStackIO [a]
findAllFiles String -> String
forall a. a -> a
id
[ String
path String -> String -> String
</> String
basename String -> String -> String
<.> String
ext
| String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
, String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
extensions ]
findFileWithExtension' :: [String]
-> [FilePath]
-> FilePath
-> NoCallStackIO (Maybe (FilePath, FilePath))
findFileWithExtension' :: [String]
-> [String] -> String -> NoCallStackIO (Maybe (String, String))
findFileWithExtension' extensions :: [String]
extensions searchPath :: [String]
searchPath baseName :: String
baseName =
((String, String) -> String)
-> [(String, String)] -> NoCallStackIO (Maybe (String, String))
forall a. (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile ((String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
(</>))
[ (String
path, String
baseName String -> String -> String
<.> String
ext)
| String
path <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
searchPath
, String
ext <- [String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
extensions ]
findFirstFile :: (a -> FilePath) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile :: (a -> String) -> [a] -> NoCallStackIO (Maybe a)
findFirstFile file :: a -> String
file = [a] -> NoCallStackIO (Maybe a)
findFirst
where findFirst :: [a] -> NoCallStackIO (Maybe a)
findFirst [] = Maybe a -> NoCallStackIO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
findFirst (x :: a
x:xs :: [a]
xs) = do Bool
exists <- String -> IO Bool
doesFileExist (a -> String
file a
x)
if Bool
exists
then Maybe a -> NoCallStackIO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x)
else [a] -> NoCallStackIO (Maybe a)
findFirst [a]
xs
findAllFiles :: (a -> FilePath) -> [a] -> NoCallStackIO [a]
findAllFiles :: (a -> String) -> [a] -> NoCallStackIO [a]
findAllFiles file :: a -> String
file = (a -> IO Bool) -> [a] -> NoCallStackIO [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> (a -> String) -> a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
file)
{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findModuleFiles :: [FilePath]
-> [String]
-> [ModuleName]
-> IO [(FilePath, FilePath)]
findModuleFiles :: [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFiles = Verbosity
-> [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFilesEx Verbosity
normal
findModuleFilesEx :: Verbosity
-> [FilePath]
-> [String]
-> [ModuleName]
-> IO [(FilePath, FilePath)]
findModuleFilesEx :: Verbosity
-> [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFilesEx verbosity :: Verbosity
verbosity searchPath :: [String]
searchPath extensions :: [String]
extensions moduleNames :: [ModuleName]
moduleNames =
(ModuleName -> IO (String, String))
-> [ModuleName] -> IO [(String, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx Verbosity
verbosity [String]
searchPath [String]
extensions) [ModuleName]
moduleNames
{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-}
findModuleFile :: [FilePath]
-> [String]
-> ModuleName
-> IO (FilePath, FilePath)
findModuleFile :: [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFile = Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx Verbosity
normal
findModuleFileEx :: Verbosity
-> [FilePath]
-> [String]
-> ModuleName
-> IO (FilePath, FilePath)
findModuleFileEx :: Verbosity
-> [String] -> [String] -> ModuleName -> IO (String, String)
findModuleFileEx verbosity :: Verbosity
verbosity searchPath :: [String]
searchPath extensions :: [String]
extensions mod_name :: ModuleName
mod_name =
IO (String, String)
-> ((String, String) -> IO (String, String))
-> Maybe (String, String)
-> IO (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (String, String)
forall a. IO a
notFound (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe (String, String) -> IO (String, String))
-> NoCallStackIO (Maybe (String, String)) -> IO (String, String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String]
-> [String] -> String -> NoCallStackIO (Maybe (String, String))
findFileWithExtension' [String]
extensions [String]
searchPath
(ModuleName -> String
ModuleName.toFilePath ModuleName
mod_name)
where
notFound :: IO a
notFound = Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$
"Error: Could not find module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
mod_name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " with any suffix: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
extensions
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " in the search path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
searchPath
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive :: String -> IO [String]
getDirectoryContentsRecursive topdir :: String
topdir = [String] -> IO [String]
recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
recurseDirectories :: [String] -> IO [String]
recurseDirectories [] = [String] -> NoCallStackIO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
recurseDirectories (dir :: String
dir:dirs :: [String]
dirs) = NoCallStackIO [String] -> NoCallStackIO [String]
forall a. IO a -> IO a
unsafeInterleaveIO (NoCallStackIO [String] -> NoCallStackIO [String])
-> NoCallStackIO [String] -> NoCallStackIO [String]
forall a b. (a -> b) -> a -> b
$ do
(files :: [String]
files, dirs' :: [String]
dirs') <- [String] -> [String] -> [String] -> IO ([String], [String])
collect [] [] ([String] -> IO ([String], [String]))
-> NoCallStackIO [String] -> IO ([String], [String])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> NoCallStackIO [String]
getDirectoryContents (String
topdir String -> String -> String
</> String
dir)
[String]
files' <- [String] -> IO [String]
recurseDirectories ([String]
dirs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
dirs)
[String] -> NoCallStackIO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
files')
where
collect :: [String] -> [String] -> [String] -> IO ([String], [String])
collect files :: [String]
files dirs' :: [String]
dirs' [] = ([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
files
,[String] -> [String]
forall a. [a] -> [a]
reverse [String]
dirs')
collect files :: [String]
files dirs' :: [String]
dirs' (entry :: String
entry:entries :: [String]
entries) | String -> Bool
ignore String
entry
= [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files [String]
dirs' [String]
entries
collect files :: [String]
files dirs' :: [String]
dirs' (entry :: String
entry:entries :: [String]
entries) = do
let dirEntry :: String
dirEntry = String
dir String -> String -> String
</> String
entry
Bool
isDirectory <- String -> IO Bool
doesDirectoryExist (String
topdir String -> String -> String
</> String
dirEntry)
if Bool
isDirectory
then [String] -> [String] -> [String] -> IO ([String], [String])
collect [String]
files (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
dirs') [String]
entries
else [String] -> [String] -> [String] -> IO ([String], [String])
collect (String
dirEntryString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
files) [String]
dirs' [String]
entries
ignore :: String -> Bool
ignore ['.'] = Bool
True
ignore ['.', '.'] = Bool
True
ignore _ = Bool
False
isInSearchPath :: FilePath -> NoCallStackIO Bool
isInSearchPath :: String -> IO Bool
isInSearchPath path :: String
path = ([String] -> Bool) -> NoCallStackIO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
path) NoCallStackIO [String]
getSearchPath
addLibraryPath :: OS
-> [FilePath]
-> [(String,String)]
-> [(String,String)]
addLibraryPath :: OS -> [String] -> [(String, String)] -> [(String, String)]
addLibraryPath os :: OS
os paths :: [String]
paths = [(String, String)] -> [(String, String)]
addEnv
where
pathsString :: String
pathsString = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] [String]
paths
ldPath :: String
ldPath = case OS
os of
OSX -> "DYLD_LIBRARY_PATH"
_ -> "LD_LIBRARY_PATH"
addEnv :: [(String, String)] -> [(String, String)]
addEnv [] = [(String
ldPath,String
pathsString)]
addEnv ((key :: String
key,value :: String
value):xs :: [(String, String)]
xs)
| String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
ldPath =
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
value
then (String
key,String
pathsString)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
xs
else (String
key,String
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
searchPathSeparatorChar -> String -> String
forall a. a -> [a] -> [a]
:String
pathsString))(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)]
xs
| Bool
otherwise = (String
key,String
value)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:[(String, String)] -> [(String, String)]
addEnv [(String, String)]
xs
moreRecentFile :: FilePath -> FilePath -> NoCallStackIO Bool
moreRecentFile :: String -> String -> IO Bool
moreRecentFile a :: String
a b :: String
b = do
Bool
exists <- String -> IO Bool
doesFileExist String
b
if Bool -> Bool
not Bool
exists
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do UTCTime
tb <- String -> IO UTCTime
getModificationTime String
b
UTCTime
ta <- String -> IO UTCTime
getModificationTime String
a
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
ta UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
tb)
existsAndIsMoreRecentThan :: FilePath -> FilePath -> NoCallStackIO Bool
existsAndIsMoreRecentThan :: String -> String -> IO Bool
existsAndIsMoreRecentThan a :: String
a b :: String
b = do
Bool
exists <- String -> IO Bool
doesFileExist String
a
if Bool -> Bool
not Bool
exists
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else String
a String -> String -> IO Bool
`moreRecentFile` String
b
createDirectoryIfMissingVerbose :: Verbosity
-> Bool
-> FilePath
-> IO ()
createDirectoryIfMissingVerbose :: Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose verbosity :: Verbosity
verbosity create_parents :: Bool
create_parents path0 :: String
path0
| Bool
create_parents = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
createDirs (String -> [String]
parents String
path0)
| Bool
otherwise = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> IO ()
createDirs (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take 1 (String -> [String]
parents String
path0))
where
parents :: String -> [String]
parents = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> [String] -> [String]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 String -> String -> String
(</>) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
normalise
createDirs :: [String] -> IO ()
createDirs [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
createDirs (dir :: String
dir:[]) = String -> (IOError -> IO ()) -> IO ()
createDir String
dir IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO
createDirs (dir :: String
dir:dirs :: [String]
dirs) =
String -> (IOError -> IO ()) -> IO ()
createDir String
dir ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> do
[String] -> IO ()
createDirs [String]
dirs
String -> (IOError -> IO ()) -> IO ()
createDir String
dir IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO
createDir :: FilePath -> (IOException -> IO ()) -> IO ()
createDir :: String -> (IOError -> IO ()) -> IO ()
createDir dir :: String
dir notExistHandler :: IOError -> IO ()
notExistHandler = do
Either IOError ()
r <- IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
tryIO (IO () -> IO (Either IOError ()))
-> IO () -> IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
createDirectoryVerbose Verbosity
verbosity String
dir
case (Either IOError ()
r :: Either IOException ()) of
Right () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Left e :: IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e -> IOError -> IO ()
notExistHandler IOError
e
| IOError -> Bool
isAlreadyExistsError IOError
e -> (do
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
dir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
) IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` ((\_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) :: IOException -> IO ())
| Bool
otherwise -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
createDirectoryVerbose :: Verbosity -> String -> IO ()
createDirectoryVerbose verbosity :: Verbosity
verbosity dir :: String
dir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
String -> IO ()
createDirectory String
dir
String -> IO ()
setDirOrdinary String
dir
copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose :: Verbosity -> String -> String -> IO ()
copyFileVerbose verbosity :: Verbosity
verbosity src :: String
src dest :: String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity ("copy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
String -> String -> IO ()
copyFile String
src String
dest
installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
installOrdinaryFile :: Verbosity -> String -> String -> IO ()
installOrdinaryFile verbosity :: Verbosity
verbosity src :: String
src dest :: String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity ("Installing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
String -> String -> IO ()
copyOrdinaryFile String
src String
dest
installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile :: Verbosity -> String -> String -> IO ()
installExecutableFile verbosity :: Verbosity
verbosity src :: String
src dest :: String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity ("Installing executable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest)
String -> String -> IO ()
copyExecutableFile String
src String
dest
installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installMaybeExecutableFile :: Verbosity -> String -> String -> IO ()
installMaybeExecutableFile verbosity :: Verbosity
verbosity src :: String
src dest :: String
dest = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Permissions
perms <- String -> IO Permissions
getPermissions String
src
if (Permissions -> Bool
executable Permissions
perms)
then Verbosity -> String -> String -> IO ()
installExecutableFile Verbosity
verbosity String
src String
dest
else Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
src String
dest
copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileTo :: Verbosity -> String -> String -> IO ()
copyFileTo verbosity :: Verbosity
verbosity dir :: String
dir file :: String
file = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let targetFile :: String
targetFile = String
dir String -> String -> String
</> String
file
Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (String -> String
takeDirectory String
targetFile)
Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
file String
targetFile
copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
-> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFilesWith :: (Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith doCopy :: Verbosity -> String -> String -> IO ()
doCopy verbosity :: Verbosity
verbosity targetDir :: String
targetDir srcFiles :: [(String, String)]
srcFiles = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let dirs :: [String]
dirs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
targetDir String -> String -> String
</>) ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([(String, String)] -> [String])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
takeDirectory (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, String)]
srcFiles
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True) [String]
dirs
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let src :: String
src = String
srcBase String -> String -> String
</> String
srcFile
dest :: String
dest = String
targetDir String -> String -> String
</> String
srcFile
in Verbosity -> String -> String -> IO ()
doCopy Verbosity
verbosity String
src String
dest
| (srcBase :: String
srcBase, srcFile :: String
srcFile) <- [(String, String)]
srcFiles ]
copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFiles :: Verbosity -> String -> [(String, String)] -> IO ()
copyFiles v :: Verbosity
v fp :: String
fp fs :: [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
copyFileVerbose Verbosity
v String
fp [(String, String)]
fs)
installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
installOrdinaryFiles :: Verbosity -> String -> [(String, String)] -> IO ()
installOrdinaryFiles v :: Verbosity
v fp :: String
fp fs :: [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
v String
fp [(String, String)]
fs)
installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
-> IO ()
installExecutableFiles :: Verbosity -> String -> [(String, String)] -> IO ()
installExecutableFiles v :: Verbosity
v fp :: String
fp fs :: [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
installExecutableFile Verbosity
v String
fp [(String, String)]
fs)
installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
-> IO ()
installMaybeExecutableFiles :: Verbosity -> String -> [(String, String)] -> IO ()
installMaybeExecutableFiles v :: Verbosity
v fp :: String
fp fs :: [(String, String)]
fs = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith Verbosity -> String -> String -> IO ()
installMaybeExecutableFile Verbosity
v String
fp [(String, String)]
fs)
installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
installDirectoryContents :: Verbosity -> String -> String -> IO ()
installDirectoryContents verbosity :: Verbosity
verbosity srcDir :: String
srcDir destDir :: String
destDir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity ("copy directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' to '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'.")
[String]
srcFiles <- String -> IO [String]
getDirectoryContentsRecursive String
srcDir
Verbosity -> String -> [(String, String)] -> IO ()
installOrdinaryFiles Verbosity
verbosity String
destDir [ (String
srcDir, String
f) | String
f <- [String]
srcFiles ]
copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive :: Verbosity -> String -> String -> IO ()
copyDirectoryRecursive verbosity :: Verbosity
verbosity srcDir :: String
srcDir destDir :: String
destDir = IO () -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> String -> IO ()
info Verbosity
verbosity ("copy directory '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
srcDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' to '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'.")
[String]
srcFiles <- String -> IO [String]
getDirectoryContentsRecursive String
srcDir
(Verbosity -> String -> String -> IO ())
-> Verbosity -> String -> [(String, String)] -> IO ()
copyFilesWith ((String -> String -> IO ())
-> Verbosity -> String -> String -> IO ()
forall a b. a -> b -> a
const String -> String -> IO ()
copyFile) Verbosity
verbosity String
destDir [ (String
srcDir, String
f)
| String
f <- [String]
srcFiles ]
doesExecutableExist :: FilePath -> NoCallStackIO Bool
doesExecutableExist :: String -> IO Bool
doesExecutableExist f :: String
f = do
Bool
exists <- String -> IO Bool
doesFileExist String
f
if Bool
exists
then do Permissions
perms <- String -> IO Permissions
getPermissions String
f
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Permissions -> Bool
executable Permissions
perms)
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
data TempFileOptions = TempFileOptions {
TempFileOptions -> Bool
optKeepTempFiles :: Bool
}
defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions = TempFileOptions :: Bool -> TempFileOptions
TempFileOptions { optKeepTempFiles :: Bool
optKeepTempFiles = Bool
False }
withTempFile :: FilePath
-> String
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile :: String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile tmpDir :: String
tmpDir template :: String
template action :: String -> Handle -> IO a
action =
TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
forall a.
TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
withTempFileEx TempFileOptions
defaultTempFileOptions String
tmpDir String
template String -> Handle -> IO a
action
withTempFileEx :: TempFileOptions
-> FilePath
-> String
-> (FilePath -> Handle -> IO a) -> IO a
withTempFileEx :: TempFileOptions
-> String -> String -> (String -> Handle -> IO a) -> IO a
withTempFileEx opts :: TempFileOptions
opts tmpDir :: String
tmpDir template :: String
template action :: String -> Handle -> IO a
action =
IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(String -> String -> IO (String, Handle)
openTempFile String
tmpDir String
template)
(\(name :: String
name, handle :: Handle
handle) -> do Handle -> IO ()
hClose Handle
handle
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TempFileOptions -> Bool
optKeepTempFiles TempFileOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
() -> IO () -> IO ()
forall a. a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist () (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
name)
(((String, Handle) -> IO a)
-> WithCallStack ((String, Handle) -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack ((String -> Handle -> IO a) -> (String, Handle) -> IO a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Handle -> IO a
String -> Handle -> IO a
action))
withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory :: Verbosity -> String -> String -> (String -> IO a) -> IO a
withTempDirectory verbosity :: Verbosity
verbosity targetDir :: String
targetDir template :: String
template f :: String -> IO a
f = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
forall a.
Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
defaultTempFileOptions String
targetDir String
template
((String -> IO a) -> WithCallStack (String -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack String -> IO a
f)
withTempDirectoryEx :: Verbosity -> TempFileOptions
-> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectoryEx :: Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx _verbosity :: Verbosity
_verbosity opts :: TempFileOptions
opts targetDir :: String
targetDir template :: String
template f :: String -> IO a
f = IO a -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(String -> String -> IO String
createTempDirectory String
targetDir String
template)
(Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TempFileOptions -> Bool
optKeepTempFiles TempFileOptions
opts)
(IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> IO () -> IO ()
forall a. a -> NoCallStackIO a -> NoCallStackIO a
handleDoesNotExist () (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
removeDirectoryRecursive)
((String -> IO a) -> WithCallStack (String -> IO a)
forall a b.
(a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack String -> IO a
f)
rewriteFileEx :: Verbosity -> FilePath -> String -> IO ()
rewriteFileEx :: Verbosity -> String -> String -> IO ()
rewriteFileEx verbosity :: Verbosity
verbosity path :: String
path newContent :: String
newContent =
(IO () -> (IOError -> IO ()) -> IO ())
-> (IOError -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
catchIO IOError -> IO ()
mightNotExist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
existingContent <- Verbosity -> IO ByteString -> IO ByteString
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
path
Int64
_ <- Int64 -> IO Int64
forall a. a -> IO a
evaluate (ByteString -> Int64
BS.length ByteString
existingContent)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
existingContent ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
newContent') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> IO () -> IO ()
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> ByteString -> IO ()
writeFileAtomic String
path ByteString
newContent'
where
newContent' :: ByteString
newContent' = String -> ByteString
toUTF8LBS String
newContent
mightNotExist :: IOError -> IO ()
mightNotExist e :: IOError
e | IOError -> Bool
isDoesNotExistError IOError
e
= Verbosity -> IO () -> IO ()
forall a. Verbosity -> IO a -> IO a
annotateIO Verbosity
verbosity (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
writeFileAtomic String
path ByteString
newContent'
| Bool
otherwise
= IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e
currentDir :: FilePath
currentDir :: String
currentDir = "."
shortRelativePath :: FilePath -> FilePath -> FilePath
shortRelativePath :: String -> String -> String
shortRelativePath from :: String
from to :: String
to =
case [String] -> [String] -> ([String], [String])
forall a. Eq a => [a] -> [a] -> ([a], [a])
dropCommonPrefix (String -> [String]
splitDirectories String
from) (String -> [String]
splitDirectories String
to) of
(stuff :: [String]
stuff, path :: [String]
path) -> [String] -> String
joinPath ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a b. a -> b -> a
const "..") [String]
stuff [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
path)
where
dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])
dropCommonPrefix :: [a] -> [a] -> ([a], [a])
dropCommonPrefix (x :: a
x:xs :: [a]
xs) (y :: a
y:ys :: [a]
ys)
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> ([a], [a])
forall a. Eq a => [a] -> [a] -> ([a], [a])
dropCommonPrefix [a]
xs [a]
ys
dropCommonPrefix xs :: [a]
xs ys :: [a]
ys = ([a]
xs,[a]
ys)
dropExeExtension :: FilePath -> FilePath
dropExeExtension :: String -> String
dropExeExtension filepath :: String
filepath =
case String -> (String, String)
splitExtension String
filepath of
(filepath' :: String
filepath', extension :: String
extension) | String
extension String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exeExtensions -> String
filepath'
| Bool
otherwise -> String
filepath
exeExtensions :: [String]
exeExtensions :: [String]
exeExtensions = case OS
buildOS of
Windows -> ["", "exe"]
Ghcjs -> ["", "exe"]
_ -> [""]
defaultPackageDesc :: Verbosity -> IO FilePath
defaultPackageDesc :: Verbosity -> IO String
defaultPackageDesc verbosity :: Verbosity
verbosity = Verbosity -> String -> IO String
tryFindPackageDesc Verbosity
verbosity String
currentDir
findPackageDesc :: FilePath
-> NoCallStackIO (Either String FilePath)
findPackageDesc :: String -> NoCallStackIO (Either String String)
findPackageDesc dir :: String
dir
= do [String]
files <- String -> NoCallStackIO [String]
getDirectoryContents String
dir
[String]
cabalFiles <- (String -> IO Bool) -> [String] -> NoCallStackIO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist
[ String
dir String -> String -> String
</> String
file
| String
file <- [String]
files
, let (name :: String
name, ext :: String
ext) = String -> (String, String)
splitExtension String
file
, Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name) Bool -> Bool -> Bool
&& String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".cabal" ]
case [String]
cabalFiles of
[] -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left String
noDesc)
[cabalFile :: String
cabalFile] -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. b -> Either a b
Right String
cabalFile)
multiple :: [String]
multiple -> Either String String -> NoCallStackIO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> String
multiDesc [String]
multiple)
where
noDesc :: String
noDesc :: String
noDesc = "No cabal file found.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Please create a package description file <pkgname>.cabal"
multiDesc :: [String] -> String
multiDesc :: [String] -> String
multiDesc l :: [String]
l = "Multiple cabal files found.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Please use only one of: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " [String]
l
tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath
tryFindPackageDesc :: Verbosity -> String -> IO String
tryFindPackageDesc verbosity :: Verbosity
verbosity dir :: String
dir =
(String -> IO String)
-> (String -> IO String) -> Either String String -> IO String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity) String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO String)
-> NoCallStackIO (Either String String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> NoCallStackIO (Either String String)
findPackageDesc String
dir
findHookedPackageDesc
:: Verbosity
-> FilePath
-> IO (Maybe FilePath)
findHookedPackageDesc :: Verbosity -> String -> IO (Maybe String)
findHookedPackageDesc verbosity :: Verbosity
verbosity dir :: String
dir = do
[String]
files <- String -> NoCallStackIO [String]
getDirectoryContents String
dir
[String]
buildInfoFiles <- (String -> IO Bool) -> [String] -> NoCallStackIO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist
[ String
dir String -> String -> String
</> String
file
| String
file <- [String]
files
, let (name :: String
name, ext :: String
ext) = String -> (String, String)
splitExtension String
file
, Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name) Bool -> Bool -> Bool
&& String
ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
buildInfoExt ]
case [String]
buildInfoFiles of
[] -> Maybe String -> NoCallStackIO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
[f :: String
f] -> Maybe String -> NoCallStackIO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
f)
_ -> Verbosity -> String -> IO (Maybe String)
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity ("Multiple files with extension " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
buildInfoExt)
buildInfoExt :: String
buildInfoExt :: String
buildInfoExt = ".buildinfo"