{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.Utils
( MergeResult (..)
, mergeBy
, duplicates
, duplicatesBy
, readMaybe
, inDir
, withEnv
, withEnvOverrides
, logDirChange
, withExtraPathEnv
, determineNumJobs
, numberOfProcessors
, removeExistingFile
, withTempFileName
, makeAbsoluteToCwd
, makeRelativeToCwd
, makeRelativeToDir
, makeRelativeCanonical
, filePathToByteString
, byteStringToFilePath
, tryCanonicalizePath
, canonicalizePathNoThrow
, moreRecentFile
, existsAndIsMoreRecentThan
, tryFindAddSourcePackageDesc
, tryFindPackageDesc
, relaxEncodingErrors
, ProgressPhase (..)
, progressMessage
, pvpize
, incVersion
, getCurrentYear
, listFilesRecursive
, listFilesInside
, safeRead
, hasElem
, concatMapM
, occursOnlyOrBefore
, giveRTSWarning
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Control.Exception as Exception
( finally
)
import qualified Control.Exception.Safe as Safe
( bracket
)
import Control.Monad
( zipWithM_
)
import Data.Bits
( shiftL
, shiftR
, (.|.)
)
import qualified Data.ByteString.Lazy as BS
import Data.List
( elemIndex
, groupBy
)
import Distribution.Compat.Environment
import Distribution.Compat.Time (getModTime)
import Distribution.Simple.Setup (Flag (..))
import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
import Distribution.Version
import System.Directory
( canonicalizePath
, doesDirectoryExist
, doesFileExist
, getCurrentDirectory
, getDirectoryContents
, removeFile
, setCurrentDirectory
)
import System.FilePath
import System.IO
( Handle
, hClose
, hGetEncoding
, hSetEncoding
, openTempFile
)
import System.IO.Unsafe (unsafePerformIO)
import Data.Time (utcToLocalTime)
import Data.Time.Calendar (toGregorian)
import Data.Time.Clock.POSIX (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone, localDay)
import GHC.Conc.Sync (getNumProcessors)
import GHC.IO.Encoding
( TextEncoding (TextEncoding)
, recover
)
import GHC.IO.Encoding.Failure
( CodingFailureMode (TransliterateCodingFailure)
, recoverEncode
)
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
import qualified System.Directory as Dir
import qualified System.IO.Error as IOError
#endif
import qualified Data.Set as Set
import Distribution.Client.Errors
mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy a -> b -> Ordering
cmp = [a] -> [b] -> [MergeResult a b]
merge
where
merge :: [a] -> [b] -> [MergeResult a b]
merge :: [a] -> [b] -> [MergeResult a b]
merge [] [b]
ys = [b -> MergeResult a b
forall a b. b -> MergeResult a b
OnlyInRight b
y | b
y <- [b]
ys]
merge [a]
xs [] = [a -> MergeResult a b
forall a b. a -> MergeResult a b
OnlyInLeft a
x | a
x <- [a]
xs]
merge (a
x : [a]
xs) (b
y : [b]
ys) =
case a
x a -> b -> Ordering
`cmp` b
y of
Ordering
GT -> b -> MergeResult a b
forall a b. b -> MergeResult a b
OnlyInRight b
y MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [b]
ys
Ordering
EQ -> a -> b -> MergeResult a b
forall a b. a -> b -> MergeResult a b
InBoth a
x b
y MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs [b]
ys
Ordering
LT -> a -> MergeResult a b
forall a b. a -> MergeResult a b
OnlyInLeft a
x MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys)
data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
duplicates :: Ord a => [a] -> [[a]]
duplicates :: forall a. Ord a => [a] -> [[a]]
duplicates = (a -> a -> Ordering) -> [a] -> [[a]]
forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy a -> a -> Ordering
cmp = ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter [a] -> Bool
forall {a}. [a] -> Bool
moreThanOne ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy a -> a -> Bool
eq ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy a -> a -> Ordering
cmp
where
eq :: a -> a -> Bool
eq :: a -> a -> Bool
eq a
a a
b = case a -> a -> Ordering
cmp a
a a
b of
Ordering
EQ -> Bool
True
Ordering
_ -> Bool
False
moreThanOne :: [a] -> Bool
moreThanOne (a
_ : a
_ : [a]
_) = Bool
True
moreThanOne [a]
_ = Bool
False
removeExistingFile :: FilePath -> IO ()
removeExistingFile :: FilePath -> IO ()
removeExistingFile FilePath
path = do
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
when exists $
removeFile path
withTempFileName
:: FilePath
-> String
-> (FilePath -> IO a)
-> IO a
withTempFileName :: forall a. FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempFileName FilePath
tmpDir FilePath
template FilePath -> IO a
action =
IO (FilePath, Handle)
-> ((FilePath, Handle) -> IO ())
-> ((FilePath, Handle) -> IO a)
-> IO a
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
Safe.bracket
(FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmpDir FilePath
template)
(\(FilePath
name, Handle
_) -> FilePath -> IO ()
removeExistingFile FilePath
name)
(\(FilePath
name, Handle
h) -> Handle -> IO ()
hClose Handle
h IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO a
action FilePath
name)
inDir :: Maybe FilePath -> IO a -> IO a
inDir :: forall a. Maybe FilePath -> IO a -> IO a
inDir Maybe FilePath
Nothing IO a
m = IO a
m
inDir (Just FilePath
d) IO a
m = do
old <- IO FilePath
getCurrentDirectory
setCurrentDirectory d
m `Exception.finally` setCurrentDirectory old
withEnv :: String -> String -> IO a -> IO a
withEnv :: forall a. FilePath -> FilePath -> IO a -> IO a
withEnv FilePath
k FilePath
v IO a
m = do
mb_old <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
k
setEnv k v
m `Exception.finally` setOrUnsetEnv k mb_old
withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a
withEnvOverrides :: forall a. [(FilePath, Maybe FilePath)] -> IO a -> IO a
withEnvOverrides [(FilePath, Maybe FilePath)]
overrides IO a
m = do
mb_olds <- (FilePath -> IO (Maybe FilePath))
-> [FilePath] -> IO [Maybe FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePath -> IO (Maybe FilePath)
lookupEnv [FilePath]
envVars
traverse_ (uncurry setOrUnsetEnv) overrides
m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds
where
envVars :: [String]
envVars :: [FilePath]
envVars = ((FilePath, Maybe FilePath) -> FilePath)
-> [(FilePath, Maybe FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Maybe FilePath) -> FilePath
forall a b. (a, b) -> a
fst [(FilePath, Maybe FilePath)]
overrides
setOrUnsetEnv :: String -> Maybe String -> IO ()
setOrUnsetEnv :: FilePath -> Maybe FilePath -> IO ()
setOrUnsetEnv FilePath
var Maybe FilePath
Nothing = FilePath -> IO ()
unsetEnv FilePath
var
setOrUnsetEnv FilePath
var (Just FilePath
val) = FilePath -> FilePath -> IO ()
setEnv FilePath
var FilePath
val
withExtraPathEnv :: [FilePath] -> IO a -> IO a
[FilePath]
paths IO a
m = do
oldPathSplit <- IO [FilePath]
getSearchPath
let newPath :: String
newPath = FilePath -> FilePath
mungePath (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([FilePath]
paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
oldPathSplit)
oldPath :: String
oldPath = FilePath -> FilePath
mungePath (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] [FilePath]
oldPathSplit
mungePath FilePath
p
| FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = FilePath
"/dev/null"
| Bool
otherwise = FilePath
p
setEnv "PATH" newPath
m `Exception.finally` setEnv "PATH" oldPath
logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange :: forall a. (FilePath -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange FilePath -> IO ()
_ Maybe FilePath
Nothing IO a
m = IO a
m
logDirChange FilePath -> IO ()
l (Just FilePath
d) IO a
m = do
FilePath -> IO ()
l (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"cabal: Entering directory '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
d FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'\n"
IO a
m
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`Exception.finally` FilePath -> IO ()
l (FilePath
"cabal: Leaving directory '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
d FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'\n")
numberOfProcessors :: Int
numberOfProcessors :: Int
numberOfProcessors = IO Int -> Int
forall a. IO a -> a
unsafePerformIO IO Int
getNumProcessors
determineNumJobs :: Flag (Maybe Int) -> Int
determineNumJobs :: Flag (Maybe Int) -> Int
determineNumJobs Flag (Maybe Int)
numJobsFlag =
case Flag (Maybe Int)
numJobsFlag of
Flag (Maybe Int)
NoFlag -> Int
1
Flag Maybe Int
Nothing -> Int
numberOfProcessors
Flag (Just Int
n) -> Int
n
makeAbsoluteToCwd :: FilePath -> IO FilePath
makeAbsoluteToCwd :: FilePath -> IO FilePath
makeAbsoluteToCwd FilePath
path
| FilePath -> Bool
isAbsolute FilePath
path = FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
| Bool
otherwise = do
cwd <- IO FilePath
getCurrentDirectory
return $! cwd </> path
makeRelativeToCwd :: FilePath -> IO FilePath
makeRelativeToCwd :: FilePath -> IO FilePath
makeRelativeToCwd FilePath
path =
FilePath -> FilePath -> FilePath
makeRelativeCanonical (FilePath -> FilePath -> FilePath)
-> IO FilePath -> IO (FilePath -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath FilePath
path IO (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO FilePath
getCurrentDirectory
makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
makeRelativeToDir FilePath
path FilePath
dir =
FilePath -> FilePath -> FilePath
makeRelativeCanonical (FilePath -> FilePath -> FilePath)
-> IO FilePath -> IO (FilePath -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath FilePath
path IO (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO FilePath
canonicalizePath FilePath
dir
makeRelativeCanonical :: FilePath -> FilePath -> FilePath
makeRelativeCanonical :: FilePath -> FilePath -> FilePath
makeRelativeCanonical FilePath
path FilePath
dir
| FilePath -> FilePath
takeDrive FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath -> FilePath
takeDrive FilePath
dir = FilePath
path
| Bool
otherwise = [FilePath] -> [FilePath] -> FilePath
go (FilePath -> [FilePath]
splitPath FilePath
path) (FilePath -> [FilePath]
splitPath FilePath
dir)
where
go :: [FilePath] -> [FilePath] -> FilePath
go (FilePath
p : [FilePath]
ps) (FilePath
d : [FilePath]
ds) | FilePath
p' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
d' = [FilePath] -> [FilePath] -> FilePath
go [FilePath]
ps [FilePath]
ds
where
(FilePath
p', FilePath
d') = (FilePath -> FilePath
dropTrailingPathSeparator FilePath
p, FilePath -> FilePath
dropTrailingPathSeparator FilePath
d)
go [] [] = FilePath
"./"
go [FilePath]
ps [FilePath]
ds = [FilePath] -> FilePath
joinPath (Int -> FilePath -> [FilePath]
forall a. Int -> a -> [a]
replicate ([FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
ds) FilePath
".." [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
ps)
filePathToByteString :: FilePath -> BS.ByteString
filePathToByteString :: FilePath -> ByteString
filePathToByteString FilePath
p =
[Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word32 -> [Word8] -> [Word8]) -> [Word8] -> [Word32] -> [Word8]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word32 -> [Word8] -> [Word8]
conv [] [Word32]
codepts
where
codepts :: [Word32]
codepts :: [Word32]
codepts = (Char -> Word32) -> FilePath -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) FilePath
p
conv :: Word32 -> [Word8] -> [Word8]
conv :: Word32 -> [Word8] -> [Word8]
conv Word32
w32 [Word8]
rest = Word8
b0 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
b1 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
b2 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: Word8
b3 Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
rest
where
b0 :: Word8
b0 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w32
b1 :: Word8
b1 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8
b2 :: Word8
b2 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16
b3 :: Word8
b3 = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w32 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24
byteStringToFilePath :: BS.ByteString -> FilePath
byteStringToFilePath :: ByteString -> FilePath
byteStringToFilePath ByteString
bs
| Int64
bslen Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
4 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
0 = FilePath
unexpected
| Bool
otherwise = Int64 -> FilePath
go Int64
0
where
unexpected :: FilePath
unexpected = FilePath
"Distribution.Client.Utils.byteStringToFilePath: unexpected"
bslen :: Int64
bslen = ByteString -> Int64
BS.length ByteString
bs
go :: Int64 -> FilePath
go Int64
i
| Int64
i Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
bslen = []
| Bool
otherwise = (Int -> Char
chr (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Char) -> Word32 -> Char
forall a b. (a -> b) -> a -> b
$ Word32
w32) Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int64 -> FilePath
go (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
4)
where
w32 :: Word32
w32 :: Word32
w32 = Word32
b0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b2 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b3 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
b0 :: Word32
b0 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
BS.index ByteString
bs Int64
i
b1 :: Word32
b1 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
b2 :: Word32
b2 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2)
b3 :: Word32
b3 = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> Word8 -> Word32
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
3)
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath FilePath
path = do
ret <- FilePath -> IO FilePath
canonicalizePath FilePath
path
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)
unless exists $
IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"
Nothing (Just ret)
#endif
return ret
canonicalizePathNoThrow :: FilePath -> IO FilePath
canonicalizePathNoThrow :: FilePath -> IO FilePath
canonicalizePathNoThrow FilePath
path = do
FilePath -> IO FilePath
canonicalizePath FilePath
path IO FilePath -> (IOError -> IO FilePath) -> IO FilePath
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` (\IOError
_ -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path)
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile FilePath
a FilePath
b = do
exists <- FilePath -> IO Bool
doesFileExist FilePath
b
if not exists
then return True
else do
tb <- getModTime b
ta <- getModTime a
return (ta > tb)
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan FilePath
a FilePath
b = do
exists <- FilePath -> IO Bool
doesFileExist FilePath
a
if not exists
then return False
else a `moreRecentFile` b
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors Handle
handle = do
maybeEncoding <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
handle
case maybeEncoding of
Just (TextEncoding FilePath
name IO (TextDecoder dstate)
decoder IO (TextEncoder estate)
encoder)
| Bool -> Bool
not (FilePath
"UTF" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
name) ->
let relax :: BufferCodec Char Word8 state -> BufferCodec Char Word8 state
relax BufferCodec Char Word8 state
x = BufferCodec Char Word8 state
x{recover = recoverEncode TransliterateCodingFailure}
in Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle (FilePath
-> IO (TextDecoder dstate)
-> IO (TextEncoder estate)
-> TextEncoding
forall dstate estate.
FilePath
-> IO (TextDecoder dstate)
-> IO (TextEncoder estate)
-> TextEncoding
TextEncoding FilePath
name IO (TextDecoder dstate)
decoder ((TextEncoder estate -> TextEncoder estate)
-> IO (TextEncoder estate) -> IO (TextEncoder estate)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoder estate -> TextEncoder estate
forall {state}.
BufferCodec Char Word8 state -> BufferCodec Char Word8 state
relax IO (TextEncoder estate)
encoder))
Maybe TextEncoding
_ ->
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindAddSourcePackageDesc Verbosity
verbosity FilePath
depPath FilePath
err =
Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindPackageDesc Verbosity
verbosity FilePath
depPath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
FilePath
err
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Failed to read cabal file of add-source dependency: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
depPath
tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
tryFindPackageDesc :: Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindPackageDesc Verbosity
verbosity FilePath
depPath FilePath
err = do
errOrCabalFile <- FilePath -> IO (Either CabalException FilePath)
findPackageDesc FilePath
depPath
case errOrCabalFile of
Right FilePath
file -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
Left CabalException
_ -> Verbosity -> CabalInstallException -> IO FilePath
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO FilePath)
-> CabalInstallException -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
TryFindPackageDescErr FilePath
err
data ProgressPhase
= ProgressDownloading
| ProgressDownloaded
| ProgressStarting
| ProgressBuilding
| ProgressHaddock
| ProgressInstalling
| ProgressCompleted
progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()
progressMessage :: Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
phase FilePath
subject = do
Verbosity -> FilePath -> IO ()
noticeNoWrap Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
phaseStr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
subject FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
where
phaseStr :: FilePath
phaseStr = case ProgressPhase
phase of
ProgressPhase
ProgressDownloading -> FilePath
"Downloading "
ProgressPhase
ProgressDownloaded -> FilePath
"Downloaded "
ProgressPhase
ProgressStarting -> FilePath
"Starting "
ProgressPhase
ProgressBuilding -> FilePath
"Building "
ProgressPhase
ProgressHaddock -> FilePath
"Haddock "
ProgressPhase
ProgressInstalling -> FilePath
"Installing "
ProgressPhase
ProgressCompleted -> FilePath
"Completed "
pvpize :: Bool -> Version -> VersionRange
pvpize :: Bool -> Version -> VersionRange
pvpize Bool
False Version
v = Version -> VersionRange
majorBoundVersion Version
v
pvpize Bool
True Version
v =
Version -> VersionRange
orLaterVersion Version
v'
VersionRange -> VersionRange -> VersionRange
`intersectVersionRanges` Version -> VersionRange
earlierVersion (Int -> Version -> Version
incVersion Int
1 Version
v')
where
v' :: Version
v' = ([Int] -> [Int]) -> Version -> Version
alterVersion (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
2) Version
v
incVersion :: Int -> Version -> Version
incVersion :: Int -> Version -> Version
incVersion Int
n = ([Int] -> [Int]) -> Version -> Version
alterVersion (Int -> [Int] -> [Int]
forall {a}. Num a => Int -> [a] -> [a]
incVersion' Int
n)
where
incVersion' :: Int -> [a] -> [a]
incVersion' Int
0 [] = [a
1]
incVersion' Int
0 (a
v : [a]
_) = [a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1]
incVersion' Int
m [] = Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
m a
0 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
1]
incVersion' Int
m (a
v : [a]
vs) = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> [a] -> [a]
incVersion' (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
vs
getCurrentYear :: IO Integer
getCurrentYear :: IO Integer
getCurrentYear = do
u <- IO UTCTime
getCurrentTime
z <- getCurrentTimeZone
let l = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
z UTCTime
u
(y, _, _) = toGregorian $ localDay l
return y
listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
listFilesInside FilePath -> IO Bool
test FilePath
dir = IO Bool -> IO [FilePath] -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (FilePath -> IO Bool
test (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
dropTrailingPathSeparator FilePath
dir) ([FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
(dirs, files) <- (FilePath -> IO Bool) -> [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
doesDirectoryExist ([FilePath] -> IO ([FilePath], [FilePath]))
-> IO [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
listContents FilePath
dir
rest <- concatMapM (listFilesInside test) dirs
pure $ files ++ rest
listFilesRecursive :: FilePath -> IO [FilePath]
listFilesRecursive :: FilePath -> IO [FilePath]
listFilesRecursive = (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
listFilesInside (IO Bool -> FilePath -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> FilePath -> IO Bool) -> IO Bool -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
listContents :: FilePath -> IO [FilePath]
listContents :: FilePath -> IO [FilePath]
listContents FilePath
dir = do
xs <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
b m a
t m a
f = do b' <- m Bool
b; if b' then t else f
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM = (m a -> m a -> m a) -> m a -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((m a -> m a -> m a) -> m a -> m a -> m a)
-> (m Bool -> m a -> m a -> m a) -> m Bool -> m a -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Bool -> m a -> m a -> m a
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
{-# INLINE concatMapM #-}
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
op = (a -> m [b] -> m [b]) -> m [b] -> [a] -> m [b]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f ([b] -> m [b]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
where
f :: a -> m [b] -> m [b]
f a
x m [b]
xs = do x' <- a -> m [b]
op a
x; if null x' then xs else do { xs' <- xs; pure $ x' ++ xs' }
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
_ [] = ([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
partitionM a -> m Bool
f (a
x : [a]
xs) = do
res <- a -> m Bool
f a
x
(as, bs) <- partitionM f xs
pure ([x | res] ++ as, [x | not res] ++ bs)
safeRead :: Read a => String -> Maybe a
safeRead :: forall a. Read a => FilePath -> Maybe a
safeRead FilePath
s
| [(a
x, FilePath
"")] <- ReadS a
forall a. Read a => ReadS a
reads FilePath
s = a -> Maybe a
forall a. a -> Maybe a
Just a
x
| Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
hasElem :: Ord a => [a] -> a -> Bool
hasElem :: forall a. Ord a => [a] -> a -> Bool
hasElem [a]
xs = (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
xs)
occursOnlyOrBefore :: Eq a => [a] -> a -> a -> Bool
occursOnlyOrBefore :: forall a. Eq a => [a] -> a -> a -> Bool
occursOnlyOrBefore [a]
xs a
x a
y = case (a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex a
x [a]
xs, a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex a
y [a]
xs) of
(Just Int
i, Just Int
j) -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
(Just Int
_, Maybe Int
_) -> Bool
True
(Maybe Int, Maybe Int)
_ -> Bool
False
giveRTSWarning :: String -> String
giveRTSWarning :: FilePath -> FilePath
giveRTSWarning FilePath
"run" =
FilePath
"Your RTS options are applied to cabal, not the "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"executable. Use '--' to separate cabal options from your "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"executable options. For example, use 'cabal run -- +RTS -N "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"to pass the '-N' RTS option to your executable."
giveRTSWarning FilePath
"test" =
FilePath
"Some RTS options were found standalone, "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"which affect cabal and not the binary. "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Please note that +RTS inside the --test-options argument "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"suffices if your goal is to affect the tested binary. "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"For example, use \"cabal test --test-options='+RTS -N'\" "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"to pass the '-N' RTS option to your binary."
giveRTSWarning FilePath
"bench" =
FilePath
"Some RTS options were found standalone, "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"which affect cabal and not the binary. Please note "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"that +RTS inside the --benchmark-options argument "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"suffices if your goal is to affect the benchmarked "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"binary. For example, use \"cabal test --benchmark-options="
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'+RTS -N'\" to pass the '-N' RTS option to your binary."
giveRTSWarning FilePath
_ =
FilePath
"Your RTS options are applied to cabal, not the "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"binary."