Cabal-syntax/src/Distribution/Utils/Generic.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE CPP #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE RankNTypes #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7
   8 -----------------------------------------------------------------------------
   9
  10 -- |
  11 -- Module      :  Distribution.Utils.Generic
  12 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
  13 -- License     :  BSD3
  14 --                portions Copyright (c) 2007, Galois Inc.
  15 --
  16 -- Maintainer  :  cabal-devel@haskell.org
  17 -- Portability :  portable
  18 --
  19 -- A large and somewhat miscellaneous collection of utility functions used
  20 -- throughout the rest of the Cabal lib and in other tools that use the Cabal
  21 -- lib like @cabal-install@. It has a very simple set of logging actions. It
  22 -- has low level functions for running programs, a bunch of wrappers for
  23 -- various directory and file functions that do extra logging.
  24 module Distribution.Utils.Generic
  25   ( -- * reading and writing files safely
  26     withFileContents
  27   , writeFileAtomic
  28
  29     -- * Unicode
  30
  31     -- ** Conversions
  32   , fromUTF8BS
  33   , fromUTF8LBS
  34   , toUTF8BS
  35   , toUTF8LBS
  36   , validateUTF8
  37
  38     -- ** File I/O
  39   , readUTF8File
  40   , withUTF8FileContents
  41   , writeUTF8File
  42
  43     -- ** BOM
  44   , ignoreBOM
  45
  46     -- ** Misc
  47   , normaliseLineEndings
  48
  49     -- * generic utils
  50   , dropWhileEndLE
  51   , takeWhileEndLE
  52   , equating
  53   , comparing
  54   , isInfixOf
  55   , intercalate
  56   , lowercase
  57   , isAscii
  58   , isAsciiAlpha
  59   , isAsciiAlphaNum
  60   , listUnion
  61   , listUnionRight
  62   , ordNub
  63   , ordNubBy
  64   , ordNubRight
  65   , safeHead
  66   , safeTail
  67   , safeLast
  68   , safeInit
  69   , unintersperse
  70   , wrapText
  71   , wrapLine
  72   , unfoldrM
  73   , spanMaybe
  74   , breakMaybe
  75   , unsnoc
  76   , unsnocNE
  77
  78     -- * Triples
  79   , fstOf3
  80   , sndOf3
  81   , trdOf3
  82
  83     -- * FilePath stuff
  84   , isAbsoluteOnAnyPlatform
  85   , isRelativeOnAnyPlatform
  86   ) where
  87
  88 import Distribution.Compat.Prelude
  89 import Prelude ()
  90
  91 import Distribution.Utils.String
  92
  93 import Data.Bits (shiftL, (.&.), (.|.))
  94 import qualified Data.ByteString as SBS
  95 import qualified Data.ByteString.Lazy as LBS
  96 import Data.List
  97   ( isInfixOf
  98   )
  99 import qualified Data.Set as Set
 100
 101 import qualified Control.Exception as Exception
 102 import System.Directory
 103   ( removeFile
 104   , renameFile
 105   )
 106 import System.FilePath
 107   ( splitFileName
 108   , (<.>)
 109   )
 110 import System.IO
 111   ( IOMode (ReadMode)
 112   , hClose
 113   , hGetContents
 114   , openBinaryTempFileWithDefaultPermissions
 115   , withBinaryFile
 116   , withFile
 117   )
 118
 119 -- -----------------------------------------------------------------------------
 120 -- Helper functions
 121
 122 -- | Wraps text to the default line width. Existing newlines are preserved.
 123 wrapText :: String -> String
 124 wrapText =
 125   unlines
 126     . map
 127       ( intercalate "\n"
 128           . map unwords
 129           . wrapLine 79
 130           . words
 131       )
 132     . lines
 133
 134 -- | Wraps a list of words to a list of lines of words of a particular width.
 135 wrapLine :: Int -> [String] -> [[String]]
 136 wrapLine width = wrap 0 []
 137   where
 138     wrap :: Int -> [String] -> [String] -> [[String]]
 139     wrap 0 [] (w : ws)
 140       | length w + 1 > width =
 141           wrap (length w) [w] ws
 142     wrap col line (w : ws)
 143       | col + length w + 1 > width =
 144           reverse line : wrap 0 [] (w : ws)
 145     wrap col line (w : ws) =
 146       let col' = col + length w + 1
 147        in wrap col' (w : line) ws
 148     wrap _ [] [] = []
 149     wrap _ line [] = [reverse line]
 150
 151 -----------------------------------
 152 -- Safely reading and writing files
 153
 154 -- | Gets the contents of a file, but guarantee that it gets closed.
 155 --
 156 -- The file is read lazily but if it is not fully consumed by the action then
 157 -- the remaining input is truncated and the file is closed.
 158 withFileContents :: FilePath -> (String -> IO a) -> IO a
 159 withFileContents name action =
 160   withFile
 161     name
 162     ReadMode
 163     (\hnd -> hGetContents hnd >>= action)
 164
 165 -- | Writes a file atomically.
 166 --
 167 -- The file is either written successfully or an IO exception is raised and
 168 -- the original file is left unchanged.
 169 --
 170 -- On windows it is not possible to delete a file that is open by a process.
 171 -- This case will give an IO exception but the atomic property is not affected.
 172 writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
 173 writeFileAtomic targetPath content = do
 174   let (targetDir, targetFile) = splitFileName targetPath
 175   Exception.bracketOnError
 176     (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
 177     (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
 178     ( \(tmpPath, handle) -> do
 179         LBS.hPut handle content
 180         hClose handle
 181         renameFile tmpPath targetPath
 182     )
 183
 184 -- ------------------------------------------------------------
 185
 186 -- * Unicode stuff
 187
 188 -- ------------------------------------------------------------
 189
 190 -- | Decode 'String' from UTF8-encoded 'BS.ByteString'
 191 --
 192 -- Invalid data in the UTF8 stream (this includes code-points @U+D800@
 193 -- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).
 194 fromUTF8BS :: SBS.ByteString -> String
 195 fromUTF8BS = decodeStringUtf8 . SBS.unpack
 196
 197 -- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's
 198 fromUTF8LBS :: LBS.ByteString -> String
 199 fromUTF8LBS = decodeStringUtf8 . LBS.unpack
 200
 201 -- | Encode 'String' to UTF8-encoded 'SBS.ByteString'
 202 --
 203 -- Code-points in the @U+D800@-@U+DFFF@ range will be encoded
 204 -- as the replacement character (i.e. @U+FFFD@).
 205 toUTF8BS :: String -> SBS.ByteString
 206 toUTF8BS = SBS.pack . encodeStringUtf8
 207
 208 -- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's
 209 toUTF8LBS :: String -> LBS.ByteString
 210 toUTF8LBS = LBS.pack . encodeStringUtf8
 211
 212 -- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.
 213 validateUTF8 :: SBS.ByteString -> Maybe Int
 214 validateUTF8 = go 0
 215   where
 216     go off bs = case SBS.uncons bs of
 217       Nothing -> Nothing
 218       Just (c, bs')
 219         | c <= 0x7F -> go (off + 1) bs'
 220         | c <= 0xBF -> Just off
 221         | c <= 0xDF -> twoBytes off c bs'
 222         | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF)
 223         | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7)
 224         | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3)
 225         | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1)
 226         | otherwise -> Just off
 227
 228     twoBytes off c0 bs = case SBS.uncons bs of
 229       Nothing -> Just off
 230       Just (c1, bs')
 231         | c1 .&. 0xC0 == 0x80 ->
 232             if d >= (0x80 :: Int)
 233               then go (off + 2) bs'
 234               else Just off
 235         | otherwise -> Just off
 236         where
 237           d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)
 238
 239     moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int
 240     moreBytes off 1 overlong cs' acc
 241       | overlong <= acc
 242       , acc <= 0x10FFFF
 243       , acc < 0xD800 || 0xDFFF < acc =
 244           go (off + 1) cs'
 245       | otherwise =
 246           Just off
 247     moreBytes off byteCount overlong bs acc = case SBS.uncons bs of
 248       Just (cn, bs')
 249         | cn .&. 0xC0 == 0x80 ->
 250             moreBytes (off + 1) (byteCount - 1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
 251       _ -> Just off
 252
 253 -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input
 254 ignoreBOM :: String -> String
 255 ignoreBOM ('\xFEFF' : string) = string
 256 ignoreBOM string = string
 257
 258 -- | Reads a UTF8 encoded text file as a Unicode String
 259 --
 260 -- Reads lazily using ordinary 'readFile'.
 261 readUTF8File :: FilePath -> IO String
 262 readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f
 263
 264 -- | Reads a UTF8 encoded text file as a Unicode String
 265 --
 266 -- Same behaviour as 'withFileContents'.
 267 withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
 268 withUTF8FileContents name action =
 269   withBinaryFile
 270     name
 271     ReadMode
 272     (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
 273
 274 -- | Writes a Unicode String as a UTF8 encoded text file.
 275 --
 276 -- Uses 'writeFileAtomic', so provides the same guarantees.
 277 writeUTF8File :: FilePath -> String -> IO ()
 278 writeUTF8File path = writeFileAtomic path . toUTF8LBS
 279
 280 -- | Fix different systems silly line ending conventions
 281 normaliseLineEndings :: String -> String
 282 normaliseLineEndings [] = []
 283 normaliseLineEndings ('\r' : '\n' : s) = '\n' : normaliseLineEndings s -- windows
 284 normaliseLineEndings ('\r' : s) = '\n' : normaliseLineEndings s -- old OS X
 285 normaliseLineEndings (c : s) = c : normaliseLineEndings s
 286
 287 -- ------------------------------------------------------------
 288
 289 -- * Common utils
 290
 291 -- ------------------------------------------------------------
 292
 293 -- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but
 294 -- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this
 295 -- version is that the one in "Data.List" is strict in elements, but spine-lazy,
 296 -- while this one is spine-strict but lazy in elements. That's what @LE@ stands
 297 -- for - "lazy in elements".
 298 --
 299 -- Example:
 300 --
 301 -- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]
 302 -- *** Exception: Prelude.undefined
 303 -- ...
 304 --
 305 -- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]
 306 -- [5,4,3]
 307 --
 308 -- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]
 309 -- [5,4,3]
 310 --
 311 -- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined]
 312 -- *** Exception: Prelude.undefined
 313 -- ...
 314 dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
 315 dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x : r) []
 316
 317 -- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but
 318 -- is usually faster (as well as being easier to read).
 319 takeWhileEndLE :: (a -> Bool) -> [a] -> [a]
 320 takeWhileEndLE p = fst . foldr go ([], False)
 321   where
 322     go x (rest, done)
 323       | not done && p x = (x : rest, False)
 324       | otherwise = (rest, True)
 325
 326 -- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of
 327 -- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's
 328 -- <http://github.com/nh2/haskell-ordnub ordnub> package.
 329 ordNub :: Ord a => [a] -> [a]
 330 ordNub = ordNubBy id
 331
 332 -- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and
 333 -- takes the nub based on that key.
 334 ordNubBy :: Ord b => (a -> b) -> [a] -> [a]
 335 ordNubBy f l = go Set.empty l
 336   where
 337     go !_ [] = []
 338     go !s (x : xs)
 339       | y `Set.member` s = go s xs
 340       | otherwise =
 341           let !s' = Set.insert y s
 342            in x : go s' xs
 343       where
 344         y = f x
 345
 346 -- | Like "Data.List.union", but has @O(n log n)@ complexity instead of
 347 -- @O(n^2)@.
 348 listUnion :: Ord a => [a] -> [a] -> [a]
 349 listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)
 350   where
 351     aSet = Set.fromList a
 352
 353 -- | A right-biased version of 'ordNub'.
 354 --
 355 -- Example:
 356 --
 357 -- >>> ordNub [1,2,1] :: [Int]
 358 -- [1,2]
 359 --
 360 -- >>> ordNubRight [1,2,1] :: [Int]
 361 -- [2,1]
 362 ordNubRight :: Ord a => [a] -> [a]
 363 ordNubRight = fst . foldr go ([], Set.empty)
 364   where
 365     go x p@(l, s) =
 366       if x `Set.member` s
 367         then p
 368         else (x : l, Set.insert x s)
 369
 370 -- | A right-biased version of 'listUnion'.
 371 --
 372 -- Example:
 373 --
 374 -- >>> listUnion [1,2,3,4,3] [2,1,1]
 375 -- [1,2,3,4,3]
 376 --
 377 -- >>> listUnionRight [1,2,3,4,3] [2,1,1]
 378 -- [4,3,2,1,1]
 379 listUnionRight :: Ord a => [a] -> [a] -> [a]
 380 listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b
 381   where
 382     bSet = Set.fromList b
 383
 384 -- | A total variant of 'head'.
 385 --
 386 -- @since 3.2.0.0
 387 safeHead :: [a] -> Maybe a
 388 safeHead [] = Nothing
 389 safeHead (x : _) = Just x
 390
 391 -- | A total variant of 'tail'.
 392 --
 393 -- @since 3.2.0.0
 394 safeTail :: [a] -> [a]
 395 safeTail [] = []
 396 safeTail (_ : xs) = xs
 397
 398 -- | A total variant of 'last'.
 399 --
 400 -- @since 3.2.0.0
 401 safeLast :: [a] -> Maybe a
 402 safeLast [] = Nothing
 403 safeLast (x : xs) = Just (foldl (\_ a -> a) x xs)
 404
 405 -- | A total variant of 'init'.
 406 --
 407 -- @since 3.2.0.0
 408 safeInit :: [a] -> [a]
 409 safeInit [] = []
 410 safeInit [_] = []
 411 safeInit (x : xs) = x : safeInit xs
 412
 413 equating :: Eq a => (b -> a) -> b -> b -> Bool
 414 equating p x y = p x == p y
 415
 416 -- | Lower case string
 417 --
 418 -- >>> lowercase "Foobar"
 419 -- "foobar"
 420 lowercase :: String -> String
 421 lowercase = map toLower
 422
 423 -- | Ascii characters
 424 isAscii :: Char -> Bool
 425 isAscii c = fromEnum c < 0x80
 426
 427 -- | Ascii letters.
 428 isAsciiAlpha :: Char -> Bool
 429 isAsciiAlpha c =
 430   ('a' <= c && c <= 'z')
 431     || ('A' <= c && c <= 'Z')
 432
 433 -- | Ascii letters and digits.
 434 --
 435 -- >>> isAsciiAlphaNum 'a'
 436 -- True
 437 --
 438 -- >>> isAsciiAlphaNum 'ä'
 439 -- False
 440 isAsciiAlphaNum :: Char -> Bool
 441 isAsciiAlphaNum c = isAscii c && isAlphaNum c
 442
 443 unintersperse :: Char -> String -> [String]
 444 unintersperse mark = unfoldr unintersperse1
 445   where
 446     unintersperse1 str
 447       | null str = Nothing
 448       | otherwise =
 449           let (this, rest) = break (== mark) str
 450            in Just (this, safeTail rest)
 451
 452 -- | Like 'break', but with 'Maybe' predicate
 453 --
 454 -- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"]
 455 -- (["foo","bar"],Just (1,["2","quu"]))
 456 --
 457 -- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"]
 458 -- (["foo","bar"],Nothing)
 459 --
 460 -- @since 2.2
 461 breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a]))
 462 breakMaybe f = go id
 463   where
 464     go !acc [] = (acc [], Nothing)
 465     go !acc (x : xs) = case f x of
 466       Nothing -> go (acc . (x :)) xs
 467       Just b -> (acc [], Just (b, xs))
 468
 469 -- | Like 'span' but with 'Maybe' predicate
 470 --
 471 -- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]]
 472 -- ([1,3],[[],[4,5],[6,7]])
 473 --
 474 -- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"]
 475 -- ([1,2],["foo"])
 476 --
 477 -- @since 2.2
 478 spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
 479 spanMaybe _ xs@[] = ([], xs)
 480 spanMaybe p xs@(x : xs') = case p x of
 481   Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)
 482   Nothing -> ([], xs)
 483
 484 -- | 'unfoldr' with monadic action.
 485 --
 486 -- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2
 487 -- [3,4,5,6,7]
 488 --
 489 -- @since 2.2
 490 unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]
 491 unfoldrM f = go
 492   where
 493     go b = do
 494       m <- f b
 495       case m of
 496         Nothing -> return []
 497         Just (a, b') -> liftM (a :) (go b')
 498
 499 -- | The opposite of 'snoc', which is the reverse of 'cons'
 500 --
 501 -- Example:
 502 --
 503 -- >>> unsnoc [1, 2, 3]
 504 -- Just ([1,2],3)
 505 --
 506 -- >>> unsnoc []
 507 -- Nothing
 508 --
 509 -- @since 3.2.0.0
 510 unsnoc :: [a] -> Maybe ([a], a)
 511 unsnoc [] = Nothing
 512 unsnoc (x : xs) = Just (unsnocNE (x :| xs))
 513
 514 -- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe'
 515 --
 516 -- Example:
 517 --
 518 -- >>> unsnocNE (1 :| [2, 3])
 519 -- ([1,2],3)
 520 --
 521 -- >>> unsnocNE (1 :| [])
 522 -- ([],1)
 523 --
 524 -- @since 3.2.0.0
 525 unsnocNE :: NonEmpty a -> ([a], a)
 526 unsnocNE (x :| xs) = go x xs
 527   where
 528     go y [] = ([], y)
 529     go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w)
 530
 531 -------------------------------------------------------------------------------
 532 -- Triples
 533 -------------------------------------------------------------------------------
 534
 535 -- | @since 3.4.0.0
 536 fstOf3 :: (a, b, c) -> a
 537 fstOf3 (a, _, _) = a
 538
 539 -- | @since 3.4.0.0
 540 sndOf3 :: (a, b, c) -> b
 541 sndOf3 (_, b, _) = b
 542
 543 -- | @since 3.4.0.0
 544 trdOf3 :: (a, b, c) -> c
 545 trdOf3 (_, _, c) = c
 546
 547 -- ------------------------------------------------------------
 548
 549 -- * FilePath stuff
 550
 551 -- ------------------------------------------------------------
 552
 553 -- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like
 554 -- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have
 555 -- platform independent heuristics.
 556 -- The System.FilePath exists in two versions, Windows and Posix. The two
 557 -- versions don't agree on what is a relative path and we don't know if we're
 558 -- given Windows or Posix paths.
 559 -- This results in false positives when running on Posix and inspecting
 560 -- Windows paths, like the hackage server does.
 561 -- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False
 562 -- System.FilePath.Windows.isAbsolute \"/hello\" == False
 563 -- This means that we would treat paths that start with \"/\" to be absolute.
 564 -- On Posix they are indeed absolute, while on Windows they are not.
 565 --
 566 -- The portable versions should be used when we might deal with paths that
 567 -- are from another OS than the host OS. For example, the Hackage Server
 568 -- deals with both Windows and Posix paths while performing the
 569 -- PackageDescription checks. In contrast, when we run 'cabal configure' we
 570 -- do expect the paths to be correct for our OS and we should not have to use
 571 -- the platform independent heuristics.
 572 isAbsoluteOnAnyPlatform :: FilePath -> Bool
 573 -- C:\\directory
 574 isAbsoluteOnAnyPlatform (drive : ':' : '\\' : _) = isAlpha drive
 575 isAbsoluteOnAnyPlatform (drive : ':' : '/' : _) = isAlpha drive
 576 -- UNC
 577 isAbsoluteOnAnyPlatform ('\\' : '\\' : _) = True
 578 -- Posix root
 579 isAbsoluteOnAnyPlatform ('/' : _) = True
 580 isAbsoluteOnAnyPlatform _ = False
 581
 582 -- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@
 583 isRelativeOnAnyPlatform :: FilePath -> Bool
 584 isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform
 585
 586 -- $setup
 587 -- >>> import Data.Maybe
 588 -- >>> import Text.Read