{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.Utils
  ( MergeResult (..)
  , mergeBy
  , duplicates
  , duplicatesBy
  , readMaybe
  , withEnv
  , withEnvOverrides
  , logDirChange
  , withExtraPathEnv
  , determineNumJobs
  , numberOfProcessors
  , removeExistingFile
  , withTempFileName
  , makeAbsoluteToCwd
  , makeRelativeToCwd
  , makeRelativeToDir
  , makeRelativeToDirS
  , makeRelativeCanonical
  , filePathToByteString
  , byteStringToFilePath
  , tryCanonicalizePath
  , canonicalizePathNoThrow
  , moreRecentFile
  , existsAndIsMoreRecentThan
  , tryReadAddSourcePackageDesc
  , tryReadGenericPackageDesc
  , 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.Client.Errors
import Distribution.Compat.Environment
import Distribution.Compat.Time (getModTime)
import Distribution.Simple.Setup (Flag (..))
import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
import Distribution.Utils.Path
  ( CWD
  , FileOrDir (..)
  , Pkg
  , RelativePath
  , SymbolicPath
  , getSymbolicPath
  , makeSymbolicPath
  , relativeSymbolicPath
  , sameDirectory
  , symbolicPathRelative_maybe
  )
import Distribution.Version

import System.Directory
  ( canonicalizePath
  , doesDirectoryExist
  , doesFileExist
  , getDirectoryContents
  , removeFile
  )
import qualified System.Directory as Directory
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.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)

-- | Generic merging utility. For sorted input lists this is a full outer join.
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

-- | Like 'removeFile', but does not throw an exception when the file does not
-- exist.
removeExistingFile :: FilePath -> IO ()
removeExistingFile :: FilePath -> IO ()
removeExistingFile FilePath
path = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
removeFile FilePath
path

-- | A variant of 'withTempFile' that only gives us the file name, and while
-- it will clean up the file afterwards, it's lenient if the file is
-- moved\/deleted.
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)

-- | Executes the action with an environment variable set to some
-- value.
--
-- Warning: This operation is NOT thread-safe, because current
-- environment is a process-global concept.
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
  Maybe FilePath
mb_old <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
k
  FilePath -> FilePath -> IO ()
setEnv FilePath
k FilePath
v
  IO a
m IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`Exception.finally` FilePath -> Maybe FilePath -> IO ()
setOrUnsetEnv FilePath
k Maybe FilePath
mb_old

-- | Executes the action with a list of environment variables and
-- corresponding overrides, where
--
-- * @'Just' v@ means \"set the environment variable's value to @v@\".
-- * 'Nothing' means \"unset the environment variable\".
--
-- Warning: This operation is NOT thread-safe, because current
-- environment is a process-global concept.
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
  [Maybe FilePath]
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
  ((FilePath, Maybe FilePath) -> IO ())
-> [(FilePath, Maybe FilePath)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((FilePath -> Maybe FilePath -> IO ())
-> (FilePath, Maybe FilePath) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> Maybe FilePath -> IO ()
setOrUnsetEnv) [(FilePath, Maybe FilePath)]
overrides
  IO a
m IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`Exception.finally` (FilePath -> Maybe FilePath -> IO ())
-> [FilePath] -> [Maybe FilePath] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ FilePath -> Maybe FilePath -> IO ()
setOrUnsetEnv [FilePath]
envVars [Maybe FilePath]
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

-- | Executes the action, increasing the PATH environment
-- in some way
--
-- Warning: This operation is NOT thread-safe, because the
-- environment variables are a process-global concept.
withExtraPathEnv :: [FilePath] -> IO a -> IO a
withExtraPathEnv :: forall a. [FilePath] -> IO a -> IO a
withExtraPathEnv [FilePath]
paths IO a
m = do
  [FilePath]
oldPathSplit <- IO [FilePath]
getSearchPath
  let newPath :: String
      newPath :: FilePath
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
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
      -- TODO: This is a horrible hack to work around the fact that
      -- setEnv can't take empty values as an argument
      mungePath :: FilePath -> FilePath
mungePath FilePath
p
        | FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = FilePath
"/dev/null"
        | Bool
otherwise = FilePath
p
  FilePath -> FilePath -> IO ()
setEnv FilePath
"PATH" FilePath
newPath
  IO a
m IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`Exception.finally` FilePath -> FilePath -> IO ()
setEnv FilePath
"PATH" FilePath
oldPath

-- | Log directory change in 'make' compatible syntax
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")

-- The number of processors is not going to change during the duration of the
-- program, so unsafePerformIO is safe here.
numberOfProcessors :: Int
numberOfProcessors :: Int
numberOfProcessors = IO Int -> Int
forall a. IO a -> a
unsafePerformIO IO Int
getNumProcessors

-- | Determine the number of jobs to use given the value of the '-j' flag.
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

-- | Given a relative path, make it absolute relative to the current
-- directory. Absolute paths are returned unmodified.
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
      FilePath
cwd <- IO FilePath
Directory.getCurrentDirectory
      FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$! FilePath
cwd FilePath -> FilePath -> FilePath
</> FilePath
path

-- | Given a path (relative or absolute), make it relative to the current
-- directory, including using @../..@ if necessary.
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
Directory.getCurrentDirectory

-- | Given a path (relative or absolute), make it relative to the given
-- directory, including using @../..@ if necessary.
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

-- | makeRelativeToDir for SymbolicPath
makeRelativeToDirS :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath CWD to -> IO (SymbolicPath dir to)
makeRelativeToDirS :: forall dir (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPath CWD to -> IO (SymbolicPath dir to)
makeRelativeToDirS Maybe (SymbolicPath CWD ('Dir dir))
Nothing SymbolicPath CWD to
s = Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPath CWD to -> IO (SymbolicPath dir to)
forall dir (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPath CWD to -> IO (SymbolicPath dir to)
makeRelativeToDirS (SymbolicPath CWD ('Dir dir) -> Maybe (SymbolicPath CWD ('Dir dir))
forall a. a -> Maybe a
Just SymbolicPath CWD ('Dir dir)
forall (allowAbsolute :: AllowAbsolute) from to.
SymbolicPathX allowAbsolute from ('Dir to)
sameDirectory) SymbolicPath CWD to
s
makeRelativeToDirS (Just SymbolicPath CWD ('Dir dir)
root) SymbolicPath CWD to
p =
  case SymbolicPath CWD to -> Maybe (RelativePath CWD to)
forall from (to :: FileOrDir).
SymbolicPath from to -> Maybe (RelativePath from to)
symbolicPathRelative_maybe SymbolicPath CWD to
p of
    -- TODO: Use AbsolutePath
    Maybe (RelativePath CWD to)
Nothing -> SymbolicPath dir to -> IO (SymbolicPath dir to)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPath dir to -> IO (SymbolicPath dir to))
-> SymbolicPath dir to -> IO (SymbolicPath dir to)
forall a b. (a -> b) -> a -> b
$ FilePath -> SymbolicPath dir to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (SymbolicPath CWD to -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath CWD to
p)
    Just RelativePath CWD to
rel_path ->
      FilePath -> SymbolicPath dir to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (FilePath -> SymbolicPath dir to)
-> IO FilePath -> IO (SymbolicPath dir to)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> IO FilePath
makeRelativeToDir (SymbolicPath CWD ('Dir dir) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath CWD ('Dir dir)
root) (RelativePath CWD to -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath RelativePath CWD to
rel_path)

-- | Given a canonical absolute path and canonical absolute dir, make the path
-- relative to the directory, including using @../..@ if necessary. Returns
-- the original absolute path if it is not on the same drive as the given 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)

-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
-- encoded as a little-endian 'Word32'.
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

-- | Reverse operation to 'filePathToByteString'.
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)

-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
-- throws an error if the path refers to a non-existent file.
{- FOURMOLU_DISABLE -}
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath FilePath
path = do
  FilePath
ret <- FilePath -> IO FilePath
canonicalizePath FilePath
path
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
  Bool
exists <- (Bool -> Bool -> Bool) -> IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(||) (FilePath -> IO Bool
doesFileExist FilePath
ret) (FilePath -> IO Bool
Dir.doesDirectoryExist FilePath
ret)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IOError -> IO ()
forall a. IOError -> IO a
IOError.ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
IOError.mkIOError IOErrorType
IOError.doesNotExistErrorType FilePath
"canonicalizePath"
                        Maybe Handle
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
ret)
#endif
  FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
ret
{- FOURMOLU_ENABLE -}

-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
-- an exception, returns the path argument unmodified.
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)

--------------------
-- Modification time

-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead
-- of getModificationTime for higher precision. We can't merge the two because
-- Distribution.Client.Time uses MIN_VERSION macros.
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile FilePath
a FilePath
b = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
b
  if Bool -> Bool
not Bool
exists
    then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      ModTime
tb <- FilePath -> IO ModTime
getModTime FilePath
b
      ModTime
ta <- FilePath -> IO ModTime
getModTime FilePath
a
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModTime
ta ModTime -> ModTime -> Bool
forall a. Ord a => a -> a -> Bool
> ModTime
tb)

-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan FilePath
a FilePath
b = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
a
  if Bool -> Bool
not Bool
exists
    then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else FilePath
a FilePath -> FilePath -> IO Bool
`moreRecentFile` FilePath
b

-- | Sets the handler for encoding errors to one that transliterates invalid
-- characters into one present in the encoding (i.e., \'?\').
-- This is opposed to the default behavior, which is to throw an exception on
-- error. This function will ignore file handles that have a Unicode encoding
-- set. It's a no-op for versions of `base` less than 4.4.
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors Handle
handle = do
  Maybe TextEncoding
maybeEncoding <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
handle
  case Maybe TextEncoding
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 ()

-- | Like 'tryFindPackageDesc', but with error specific to add-source deps.
tryReadAddSourcePackageDesc
  :: Verbosity
  -> FilePath
  -> String
  -> IO GenericPackageDescription
tryReadAddSourcePackageDesc :: Verbosity -> FilePath -> FilePath -> IO GenericPackageDescription
tryReadAddSourcePackageDesc Verbosity
verbosity FilePath
depPath FilePath
err = do
  let pkgDir :: SymbolicPath from to
pkgDir = FilePath -> SymbolicPath from to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
depPath
  RelativePath Pkg 'File
pkgDescPath <-
    Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> FilePath
-> IO (RelativePath Pkg 'File)
try_find_package_desc Verbosity
verbosity SymbolicPath CWD ('Dir Pkg)
forall {from} {to :: FileOrDir}. SymbolicPath from to
pkgDir (FilePath -> IO (RelativePath Pkg 'File))
-> FilePath -> IO (RelativePath Pkg 'File)
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
  HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just SymbolicPath CWD ('Dir Pkg)
forall {from} {to :: FileOrDir}. SymbolicPath from to
pkgDir) (RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath RelativePath Pkg 'File
pkgDescPath)

-- | Try to read a @.cabal@ file, in directory @depPath@. Fails if one cannot be
--  found, with @err@ prefixing the error message. This function simply allows
--  us to give a more descriptive error than that provided by @findPackageDesc@.
tryReadGenericPackageDesc
  :: Verbosity
  -> SymbolicPath CWD (Dir Pkg)
  -> String
  -> IO GenericPackageDescription
tryReadGenericPackageDesc :: Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> FilePath
-> IO GenericPackageDescription
tryReadGenericPackageDesc Verbosity
verbosity SymbolicPath CWD ('Dir Pkg)
pkgDir FilePath
err = do
  RelativePath Pkg 'File
pkgDescPath <- Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> FilePath
-> IO (RelativePath Pkg 'File)
try_find_package_desc Verbosity
verbosity SymbolicPath CWD ('Dir Pkg)
pkgDir FilePath
err
  HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just SymbolicPath CWD ('Dir Pkg)
pkgDir) (RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath RelativePath Pkg 'File
pkgDescPath)

-- | Internal helper function for 'tryReadAddSourcePackageDesc' and 'tryReadGenericPackageDesc'.
try_find_package_desc
  :: Verbosity
  -> SymbolicPath CWD (Dir Pkg)
  -> String
  -> IO (RelativePath Pkg File)
try_find_package_desc :: Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> FilePath
-> IO (RelativePath Pkg 'File)
try_find_package_desc Verbosity
verbosity SymbolicPath CWD ('Dir Pkg)
pkgDir FilePath
err = do
  Either CabalException (RelativePath Pkg 'File)
errOrCabalFile <- Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (Either CabalException (RelativePath Pkg 'File))
findPackageDesc (SymbolicPath CWD ('Dir Pkg) -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. a -> Maybe a
Just SymbolicPath CWD ('Dir Pkg)
pkgDir)
  case Either CabalException (RelativePath Pkg 'File)
errOrCabalFile of
    Right RelativePath Pkg 'File
file -> RelativePath Pkg 'File -> IO (RelativePath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RelativePath Pkg 'File
file
    Left CabalException
_ -> Verbosity -> CabalInstallException -> IO (RelativePath Pkg 'File)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO (RelativePath Pkg 'File))
-> CabalInstallException -> IO (RelativePath Pkg 'File)
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
TryFindPackageDescErr FilePath
err

-- | Phase of building a dependency. Represents current status of package
-- dependency processing. See #4040 for details.
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    "

-- | Given a version, return an API-compatible (according to PVP) version range.
--
-- If the boolean argument denotes whether to use a desugared
-- representation (if 'True') or the new-style @^>=@-form (if
-- 'False').
--
-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the
-- same as @0.4.*@).
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

-- | Increment the nth version component (counting from 0).
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

-- | Returns the current calendar year.
getCurrentYear :: IO Integer
getCurrentYear :: IO Integer
getCurrentYear = do
  UTCTime
u <- IO UTCTime
getCurrentTime
  TimeZone
z <- IO TimeZone
getCurrentTimeZone
  let l :: LocalTime
l = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
z UTCTime
u
      (Integer
y, Int
_, Int
_) = Day -> (Integer, Int, Int)
toGregorian (Day -> (Integer, Int, Int)) -> Day -> (Integer, Int, Int)
forall a b. (a -> b) -> a -> b
$ LocalTime -> Day
localDay LocalTime
l
  Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
y

-- | From System.Directory.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
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
  ([FilePath]
dirs, [FilePath]
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
  [FilePath]
rest <- (FilePath -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((FilePath -> IO Bool) -> FilePath -> IO [FilePath]
listFilesInside FilePath -> IO Bool
test) [FilePath]
dirs
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rest

-- | From System.Directory.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
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)

-- | From System.Directory.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
listContents :: FilePath -> IO [FilePath]
listContents :: FilePath -> IO [FilePath]
listContents FilePath
dir = do
  [FilePath]
xs <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
x | FilePath
x <- [FilePath]
xs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') FilePath
x]

-- | From Control.Monad.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
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 Bool
b' <- m Bool
b; if Bool
b' then m a
t else m a
f

-- | 'ifM' with swapped branches:
--   @ifNotM b t f = ifM (not <$> b) t 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

-- | From Control.Monad.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
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 [b]
x' <- a -> m [b]
op a
x; if [b] -> Bool
forall {a}. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
x' then m [b]
xs else do { [b]
xs' <- m [b]
xs; [b] -> m [b]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ [b]
x' [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
xs' }

-- | From Control.Monad.Extra
--   https://hackage.haskell.org/package/extra-1.7.9
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
  Bool
res <- a -> m Bool
f a
x
  ([a]
as, [a]
bs) <- (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
  ([a], [a]) -> m ([a], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
x | Bool
res] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as, [a
x | Bool -> Bool
not Bool
res] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
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 xs x = elem x xs@ except that @xs@ is turned into a 'Set' first.
--   Use underapplied to speed up subsequent lookups, e.g. @filter (hasElem xs) ys@.
--   Only amortized when used several times!
--
--   Time complexity \(O((n+m) \log(n))\) for \(m\) lookups in a list of length \(n\).
--   (Compare this to 'elem''s \(O(nm)\).)
--
--   This is [Agda.Utils.List.hasElem](https://hackage.haskell.org/package/Agda-2.6.2.2/docs/Agda-Utils-List.html#v:hasElem).
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)

-- True if x occurs before y
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."