Utils.hs 11.4 KB
Newer Older
1
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
2
3
4

module Distribution.Client.Utils ( MergeResult(..)
                                 , mergeBy, duplicates, duplicatesBy
5
                                 , readMaybe
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
6
7
                                 , inDir, logDirChange
                                 , determineNumJobs, numberOfProcessors
8
                                 , removeExistingFile
9
                                 , withTempFileName
10
11
12
                                 , makeAbsoluteToCwd
                                 , makeRelativeToCwd, makeRelativeToDir
                                 , filePathToByteString
13
                                 , byteStringToFilePath, tryCanonicalizePath
14
                                 , canonicalizePathNoThrow
15
                                 , moreRecentFile, existsAndIsMoreRecentThan
16
17
                                 , tryFindAddSourcePackageDesc
                                 , tryFindPackageDesc
18
                                 , relaxEncodingErrors)
19
       where
Duncan Coutts's avatar
Duncan Coutts committed
20

21
22
23
import Distribution.Compat.Exception   ( catchIO )
import Distribution.Client.Compat.Time ( getModTime )
import Distribution.Simple.Setup       ( Flag(..) )
24
import Distribution.Simple.Utils       ( die, findPackageDesc )
25
import qualified Data.ByteString.Lazy as BS
26
27
28
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
29
30
import Control.Monad
         ( when )
31
32
33
34
import Data.Bits
         ( (.|.), shiftL, shiftR )
import Data.Char
         ( ord, chr )
35
36
37
38
#if MIN_VERSION_base(4,6,0)
import Text.Read
         ( readMaybe )
#endif
39
import Data.List
40
         ( isPrefixOf, sortBy, groupBy )
41
42
import Data.Word
         ( Word8, Word32)
43
import Foreign.C.Types ( CInt(..) )
44
import qualified Control.Exception as Exception
45
         ( finally, bracket )
46
import System.Directory
47
48
         ( canonicalizePath, doesFileExist, getCurrentDirectory
         , removeFile, setCurrentDirectory )
49
import System.FilePath
50
         ( (</>), isAbsolute, takeDrive, splitPath, joinPath )
51
import System.IO
52
         ( Handle, hClose, openTempFile
53
54
55
56
#if MIN_VERSION_base(4,4,0)
         , hGetEncoding, hSetEncoding
#endif
         )
57
58
import System.IO.Unsafe ( unsafePerformIO )

59
#if MIN_VERSION_base(4,4,0)
60
61
62
63
import GHC.IO.Encoding
         ( recover, TextEncoding(TextEncoding) )
import GHC.IO.Encoding.Failure
         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )
64
#endif
65

66
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
67
import Prelude hiding (ioError)
68
import Control.Monad (liftM2, unless)
69
import System.Directory (doesDirectoryExist)
70
import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)
71
72
#endif

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
-- | Generic merging utility. For sorted input lists this is a full outer join.
--
-- * The result list never contains @(Nothing, Nothing)@.
--
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy cmp = merge
  where
    merge []     ys     = [ OnlyInRight y | y <- ys]
    merge xs     []     = [ OnlyInLeft  x | x <- xs]
    merge (x:xs) (y:ys) =
      case x `cmp` y of
        GT -> OnlyInRight   y : merge (x:xs) ys
        EQ -> InBoth      x y : merge xs     ys
        LT -> OnlyInLeft  x   : merge xs  (y:ys)

data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b

duplicates :: Ord a => [a] -> [[a]]
duplicates = duplicatesBy compare

duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
  where
    eq a b = case cmp a b of
               EQ -> True
               _  -> False
    moreThanOne (_:_:_) = True
    moreThanOne _       = False
101

102
103
104
105
106
107
108
109
#if !MIN_VERSION_base(4,6,0)
-- | An implementation of readMaybe, for compatability with older base versions.
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
                [(x,"")] -> Just x
                _        -> Nothing
#endif

110
111
112
113
114
115
116
117
-- | Like 'removeFile', but does not throw an exception when the file does not
-- exist.
removeExistingFile :: FilePath -> IO ()
removeExistingFile path = do
  exists <- doesFileExist path
  when exists $
    removeFile path

118
119
120
121
122
123
124
125
126
127
128
129
130
-- | 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 tmpDir template action =
  Exception.bracket
    (openTempFile tmpDir template)
    (\(name, _) -> removeExistingFile name)
    (\(name, h) -> hClose h >> action name)

131
-- | Executes the action in the specified directory.
132
133
134
--
-- Warning: This operation is NOT thread-safe, because current
-- working directory is a process-global concept.
refold's avatar
refold committed
135
inDir :: Maybe FilePath -> IO a -> IO a
136
137
138
139
140
inDir Nothing m = m
inDir (Just d) m = do
  old <- getCurrentDirectory
  setCurrentDirectory d
  m `Exception.finally` setCurrentDirectory old
141

142
143
144
145
146
147
148
149
-- | Log directory change in 'make' compatible syntax
logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange _ Nothing m = m
logDirChange l (Just d) m = do
  l $ "cabal: Entering directory '" ++ d ++ "'\n"
  m `Exception.finally`
    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")

150
151
152
153
154
155
foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt

-- The number of processors is not going to change during the duration of the
-- program, so unsafePerformIO is safe here.
numberOfProcessors :: Int
numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
156

157
158
159
160
161
162
163
164
-- | Determine the number of jobs to use given the value of the '-j' flag.
determineNumJobs :: Flag (Maybe Int) -> Int
determineNumJobs numJobsFlag =
  case numJobsFlag of
    NoFlag        -> 1
    Flag Nothing  -> numberOfProcessors
    Flag (Just n) -> n

165
166
167
168
169
170
-- | Given a relative path, make it absolute relative to the current
-- directory. Absolute paths are returned unmodified.
makeAbsoluteToCwd :: FilePath -> IO FilePath
makeAbsoluteToCwd path | isAbsolute path = return path
                       | otherwise       = do cwd <- getCurrentDirectory
                                              return $! cwd </> path
171

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
-- | Given a path (relative or absolute), make it relative to the current
-- directory, including using @../..@ if necessary.
makeRelativeToCwd :: FilePath -> IO FilePath
makeRelativeToCwd path =
    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory

-- | Given a path (relative or absolute), make it relative to the given
-- directory, including using @../..@ if necessary.
makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
makeRelativeToDir path dir =
    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath 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 path dir
  | takeDrive path /= takeDrive dir = path
  | otherwise                       = go (splitPath path) (splitPath dir)
  where
    go (p:ps) (d:ds) | p == d = go ps ds
    go    []     []           = "./"
    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
-- encoded as a little-endian 'Word32'.
filePathToByteString :: FilePath -> BS.ByteString
filePathToByteString p =
  BS.pack $ foldr conv [] codepts
  where
    codepts :: [Word32]
    codepts = map (fromIntegral . ord) p

    conv :: Word32 -> [Word8] -> [Word8]
    conv w32 rest = b0:b1:b2:b3:rest
      where
        b0 = fromIntegral $ w32
        b1 = fromIntegral $ w32 `shiftR` 8
        b2 = fromIntegral $ w32 `shiftR` 16
        b3 = fromIntegral $ w32 `shiftR` 24

-- | Reverse operation to 'filePathToByteString'.
byteStringToFilePath :: BS.ByteString -> FilePath
byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected
                        | otherwise = go 0
  where
    unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"
    bslen = BS.length bs

    go i | i == bslen = []
         | otherwise = (chr . fromIntegral $ w32) : go (i+4)
      where
        w32 :: Word32
        w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)
        b0 = fromIntegral $ BS.index bs i
        b1 = fromIntegral $ BS.index bs (i + 1)
        b2 = fromIntegral $ BS.index bs (i + 2)
        b3 = fromIntegral $ BS.index bs (i + 3)
230

231
232
-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
-- throws an error if the path refers to a non-existent file.
233
234
235
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath path = do
  ret <- canonicalizePath path
236
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
237
238
  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)
  unless exists $
239
240
    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"
                        Nothing (Just ret)
241
242
#endif
  return ret
243
244
245
246
247
248

-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
-- an exception, returns the path argument unmodified.
canonicalizePathNoThrow :: FilePath -> IO FilePath
canonicalizePathNoThrow path = do
  canonicalizePath path `catchIO` (\_ -> return path)
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

--------------------
-- 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 a b = do
  exists <- doesFileExist 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 a b = do
  exists <- doesFileExist a
  if not exists
    then return False
    else a `moreRecentFile` b
272
273
274
275
276

-- | 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
277
-- set. It's a no-op for versions of `base` less than 4.4.
278
279
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors handle = do
280
#if MIN_VERSION_base(4,4,0)
281
282
283
284
285
  maybeEncoding <- hGetEncoding handle
  case maybeEncoding of
    Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->
      let relax x = x { recover = recoverEncode TransliterateCodingFailure }
      in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
286
    _ ->
287
#endif
288
      return ()
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

-- |Like 'tryFindPackageDesc', but with error specific to add-source deps.
tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath
tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $
    err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "
    ++ 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 :: FilePath -> String -> IO FilePath
tryFindPackageDesc depPath err = do
    errOrCabalFile <- findPackageDesc depPath
    case errOrCabalFile of
        Right file -> return file
        Left _ -> die err