{-# LANGUAGE ScopedTypeVariables, CPP #-}

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
  , findOpenProgramLocation
  , relaxEncodingErrors
  , ProgressPhase (..)
  , progressMessage
  , pvpize
  , incVersion
  , getCurrentYear
  , listFilesRecursive
  , listFilesInside
  , safeRead
  , hasElem
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Compat.Environment
import Distribution.Compat.Time        ( getModTime )
import Distribution.Simple.Setup       ( Flag(..) )
import Distribution.Version
import Distribution.Simple.Utils       ( die', findPackageDesc, noticeNoWrap )
import Distribution.System             ( Platform (..), OS(..))
import qualified Data.ByteString.Lazy as BS
import Data.Bits
         ( (.|.), shiftL, shiftR )
import System.FilePath
import Control.Monad
         ( zipWithM_ )
import Data.List
         ( groupBy )
import qualified Control.Exception as Exception
         ( finally )
import qualified Control.Exception.Safe as Safe
         ( bracket )
import System.Directory
         ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory
         , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist )
import System.IO
         ( Handle, hClose, openTempFile
         , hGetEncoding, hSetEncoding
         )
import System.IO.Unsafe ( unsafePerformIO )

import GHC.Conc.Sync ( getNumProcessors )
import GHC.IO.Encoding
         ( recover, TextEncoding(TextEncoding) )
import GHC.IO.Encoding.Failure
         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )
import Data.Time.Clock.POSIX (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone, localDay)
import Data.Time (utcToLocalTime)
import Data.Time.Calendar (toGregorian)
#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

-- | 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     = [ forall a b. b -> MergeResult a b
OnlyInRight b
y | b
y <- [b]
ys]
    merge [a]
xs     []     = [ 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 -> forall a b. b -> MergeResult a b
OnlyInRight   b
y forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge (a
xforall a. a -> [a] -> [a]
:[a]
xs) [b]
ys
        Ordering
EQ -> forall a b. a -> b -> MergeResult a b
InBoth      a
x b
y forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs     [b]
ys
        Ordering
LT -> forall a b. a -> MergeResult a b
OnlyInLeft  a
x   forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs  (b
yforall 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 = forall a. (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy 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 = forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. [a] -> Bool
moreThanOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy a -> a -> Bool
eq forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists 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 =
  forall (m :: * -> *) a b c.
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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO a
action FilePath
name)

-- | Executes the action in the specified directory.
--
-- Warning: This operation is NOT thread-safe, because current
-- working directory is a process-global concept.
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
  FilePath
old <- IO FilePath
getCurrentDirectory
  FilePath -> IO ()
setCurrentDirectory FilePath
d
  IO a
m forall a b. IO a -> IO b -> IO a
`Exception.finally` FilePath -> IO ()
setCurrentDirectory FilePath
old

-- | 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 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO (Maybe FilePath)
lookupEnv [FilePath]
envVars
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> Maybe FilePath -> IO ()
setOrUnsetEnv) [(FilePath, Maybe FilePath)]
overrides
  IO a
m forall a b. IO a -> IO b -> IO a
`Exception.finally` 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 = forall a b. (a -> b) -> [a] -> [b]
map 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char
searchPathSeparator] ([FilePath]
paths forall a. [a] -> [a] -> [a]
++ [FilePath]
oldPathSplit)
      oldPath :: String
      oldPath :: FilePath
oldPath = FilePath -> FilePath
mungePath forall a b. (a -> b) -> a -> b
$ 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 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 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 forall a b. (a -> b) -> a -> b
$ FilePath
"cabal: Entering directory '" forall a. [a] -> [a] -> [a]
++ FilePath
d forall a. [a] -> [a] -> [a]
++ FilePath
"'\n"
  IO a
m forall a b. IO a -> IO b -> IO a
`Exception.finally`
    (FilePath -> IO ()
l forall a b. (a -> b) -> a -> b
$ FilePath
"cabal: Leaving directory '" forall a. [a] -> [a] -> [a]
++ FilePath
d 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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
                       | Bool
otherwise       = do FilePath
cwd <- IO FilePath
getCurrentDirectory
                                              forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath FilePath
path forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO FilePath
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath FilePath
path forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> IO FilePath
canonicalizePath FilePath
dir

-- | 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 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' 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 (forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
ds) 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 forall a b. (a -> 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
b0forall a. a -> [a] -> [a]
:Word8
b1forall a. a -> [a] -> [a]
:Word8
b2forall a. a -> [a] -> [a]
:Word8
b3forall a. a -> [a] -> [a]
:[Word8]
rest
      where
        b0 :: Word8
b0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
w32
        b1 :: Word8
b1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
w32 forall a. Bits a => a -> Int -> a
`shiftR` Int
8
        b2 :: Word8
b2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
w32 forall a. Bits a => a -> Int -> a
`shiftR` Int
16
        b3 :: Word8
b3 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
w32 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 forall a. Integral a => a -> a -> a
`mod` Int64
4 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 forall a. Eq a => a -> a -> Bool
== Int64
bslen = []
         | Bool
otherwise = (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word32
w32) forall a. a -> [a] -> [a]
: Int64 -> FilePath
go (Int64
iforall a. Num a => a -> a -> a
+Int64
4)
      where
        w32 :: Word32
        w32 :: Word32
w32 = Word32
b0 forall a. Bits a => a -> a -> a
.|. (Word32
b1 forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. (Word32
b2 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|. (Word32
b3 forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
        b0 :: Word32
b0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
BS.index ByteString
bs Int64
i
        b1 :: Word32
b1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i forall a. Num a => a -> a -> a
+ Int64
1)
        b2 :: Word32
b2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i forall a. Num a => a -> a -> a
+ Int64
2)
        b3 :: Word32
b3 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int64 -> Word8
BS.index ByteString
bs (Int64
i 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
  FilePath
ret <- FilePath -> IO FilePath
canonicalizePath FilePath
path
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
  Bool
exists <- 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)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
    forall a. IOError -> IO a
IOError.ioError forall a b. (a -> b) -> a -> b
$ IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
IOError.mkIOError IOErrorType
IOError.doesNotExistErrorType FilePath
"canonicalizePath"
                        forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just FilePath
ret)
#endif
  forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
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 forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` (\IOError
_ -> 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 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
            forall (m :: * -> *) a. Monad m => a -> m a
return (ModTime
ta 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 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" 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 :: Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recover = CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
TransliterateCodingFailure }
      in Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle (forall dstate estate.
FilePath
-> IO (TextDecoder dstate)
-> IO (TextEncoder estate)
-> TextEncoding
TextEncoding FilePath
name IO (TextDecoder dstate)
decoder (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {state}.
BufferCodec Char Word8 state -> BufferCodec Char Word8 state
relax IO (TextEncoder estate)
encoder))
    Maybe TextEncoding
_ ->
      forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |Like 'tryFindPackageDesc', but with error specific to add-source deps.
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 forall a b. (a -> b) -> a -> b
$
    FilePath
err forall a. [a] -> [a] -> [a]
++ FilePath
"\n" forall a. [a] -> [a] -> [a]
++ FilePath
"Failed to read cabal file of add-source dependency: "
    forall a. [a] -> [a] -> [a]
++ FilePath
depPath

-- |Try to find 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@.
tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
tryFindPackageDesc :: Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindPackageDesc Verbosity
verbosity FilePath
depPath FilePath
err = do
    Either FilePath FilePath
errOrCabalFile <- FilePath -> IO (Either FilePath FilePath)
findPackageDesc FilePath
depPath
    case Either FilePath FilePath
errOrCabalFile of
        Right FilePath
file -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
file
        Left FilePath
_ -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
err

findOpenProgramLocation :: Platform -> IO (Either String FilePath)
findOpenProgramLocation :: Platform -> IO (Either FilePath FilePath)
findOpenProgramLocation (Platform Arch
_ OS
os) =
  let
    locate :: FilePath -> IO (Either FilePath FilePath)
locate FilePath
name = do
      Maybe FilePath
exe <- FilePath -> IO (Maybe FilePath)
findExecutable FilePath
name
      case Maybe FilePath
exe of
        Just FilePath
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right FilePath
s)
        Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (FilePath
"Couldn't find file-opener program `" forall a. Semigroup a => a -> a -> a
<> FilePath
name forall a. Semigroup a => a -> a -> a
<> FilePath
"`"))
    xdg :: IO (Either FilePath FilePath)
xdg = FilePath -> IO (Either FilePath FilePath)
locate FilePath
"xdg-open"
  in case OS
os of
    OS
Windows -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right FilePath
"start")
    OS
OSX -> FilePath -> IO (Either FilePath FilePath)
locate FilePath
"open"
    OS
Linux -> IO (Either FilePath FilePath)
xdg
    OS
FreeBSD -> IO (Either FilePath FilePath)
xdg
    OS
OpenBSD -> IO (Either FilePath FilePath)
xdg
    OS
NetBSD -> IO (Either FilePath FilePath)
xdg
    OS
DragonFly -> IO (Either FilePath FilePath)
xdg
    OS
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (FilePath
"Couldn't determine file-opener program for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show OS
os))


-- | 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 forall a b. (a -> b) -> a -> b
$ FilePath
phaseStr forall a. [a] -> [a] -> [a]
++ FilePath
subject 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 (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 (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
vforall a. Num a => a -> a -> a
+a
1]
    incVersion' Int
m []     = forall a. Int -> a -> [a]
replicate Int
m a
0 forall a. [a] -> [a] -> [a]
++ [a
1]
    incVersion' Int
m (a
v:[a]
vs) = a
v forall a. a -> [a] -> [a]
: Int -> [a] -> [a]
incVersion' (Int
mforall 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 forall a b. (a -> b) -> a -> b
$ LocalTime -> Day
localDay LocalTime
l
  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 = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (FilePath -> IO Bool
test forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
dropTrailingPathSeparator FilePath
dir) (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ do
    ([FilePath]
dirs,[FilePath]
files) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
doesDirectoryExist forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
listContents FilePath
dir
    [FilePath]
rest <- 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [FilePath]
files 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 (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
x | FilePath
x <- [FilePath]
xs, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f (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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
x' then m [b]
xs else do [b]
xs' <- m [b]
xs; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [b]
x' 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
_ [] = 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) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
f [a]
xs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a
x | Bool
res]forall a. [a] -> [a] -> [a]
++[a]
as, [a
x | Bool -> Bool
not Bool
res]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
"")] <- forall a. Read a => ReadS a
reads FilePath
s = forall a. a -> Maybe a
Just a
x
  | Bool
otherwise = 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 = (forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a. Ord a => [a] -> Set a
Set.fromList [a]
xs)