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

module Distribution.Client.Utils
  ( MergeResult (..)
  , mergeBy
  , duplicates
  , duplicatesBy
  , readMaybe
  , withEnv
  , withEnvOverrides
  , logDirChange
  , withExtraPathEnv
  , determineNumJobs
  , numberOfProcessors
  , 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, pattern Flag, pattern NoFlag)
import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, removeFileForcibly)
import Distribution.Utils.Path
  ( CWD
  , FileOrDir (..)
  , Pkg
  , RelativePath
  , SymbolicPath
  , getSymbolicPath
  , makeSymbolicPath
  , relativeSymbolicPath
  , sameDirectory
  , symbolicPathRelative_maybe
  )
import Distribution.Version

import System.Directory
  ( canonicalizePath
  , doesDirectoryExist
  , doesFileExist
  , listDirectory
  )
import qualified System.Directory as Directory
import System.FilePath
import System.IO
  ( Handle
  , hClose
  , hGetEncoding
  , hSetEncoding
  , openTempFile
  )
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.Set as Set
import Data.Time (utcToLocalTime)
import Data.Time.Calendar (toGregorian)
import Data.Time.Clock.POSIX (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone, localDay)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import GHC.Conc.Sync (getNumProcessors)
import GHC.IO.Encoding
  ( TextEncoding (TextEncoding)
  , recover
  )
import GHC.IO.Encoding.Failure
  ( CodingFailureMode (TransliterateCodingFailure)
  , recoverEncode
  )
import qualified System.Directory as Dir
import qualified System.IO.Error as IOError

-- | 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] -> [NonEmpty a]
duplicates :: forall a. Ord a => [a] -> [NonEmpty a]
duplicates = (a -> a -> Ordering) -> [a] -> [NonEmpty a]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
duplicatesBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
duplicatesBy a -> a -> Ordering
cmp = ([a] -> Maybe (NonEmpty a)) -> [[a]] -> [NonEmpty a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [a] -> Maybe (NonEmpty a)
forall {a}. [a] -> Maybe (NonEmpty a)
moreThanOne ([[a]] -> [NonEmpty a]) -> ([a] -> [[a]]) -> [a] -> [NonEmpty 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] -> Maybe (NonEmpty a)
moreThanOne (a
x : xs :: [a]
xs@(a
_ : [a]
_)) = NonEmpty a -> Maybe (NonEmpty a)
forall a. a -> Maybe a
Just (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
    moreThanOne [a]
_ = Maybe (NonEmpty a)
forall a. Maybe a
Nothing

-- | 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 ()
removeFileForcibly 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
  mb_old <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
k
  setEnv k v
  m `Exception.finally` setOrUnsetEnv k 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
  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

-- | 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
  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
      -- TODO: This is a horrible hack to work around the fact that
      -- setEnv can't take empty values as an argument
      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

-- | 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
{-# NOINLINE numberOfProcessors #-}

-- | 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
      cwd <- IO FilePath
Directory.getCurrentDirectory
      return $! cwd </> 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
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.
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath FilePath
path = do
  ret <- FilePath -> IO FilePath
canonicalizePath FilePath
path
  exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)
  unless exists $
    IOError.ioError $
      IOError.mkIOError
        IOError.doesNotExistErrorType
        "canonicalizePath"
        Nothing
        (Just ret)
  return ret

-- | 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
  exists <- FilePath -> IO Bool
doesFileExist FilePath
b
  if not exists
    then return True
    else do
      tb <- getModTime b
      ta <- getModTime a
      return (ta > 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
  exists <- FilePath -> IO Bool
doesFileExist FilePath
a
  if not exists
    then return False
    else a `moreRecentFile` 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
  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 ()

-- | 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
  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
  readGenericPackageDescription verbosity (Just pkgDir) (relativeSymbolicPath 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
  pkgDescPath <- Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> FilePath
-> IO (RelativePath Pkg 'File)
try_find_package_desc Verbosity
verbosity SymbolicPath CWD ('Dir Pkg)
pkgDir FilePath
err
  readGenericPackageDescription verbosity (Just pkgDir) (relativeSymbolicPath 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
  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 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, 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
  u <- IO UTCTime
getCurrentTime
  z <- getCurrentTimeZone
  let l = TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
z UTCTime
u
      (y, _, _) = toGregorian $ localDay l
  return 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
  (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

-- | 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)

listContents :: FilePath -> IO [FilePath]
listContents :: FilePath -> IO [FilePath]
listContents FilePath
dir =
  (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
dir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
dir

-- | 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 b' <- m Bool
b; if b' then t else 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 x' <- a -> m [b]
op a
x; if null x' then xs else do { xs' <- xs; pure $ x' ++ 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
  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 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."