{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- License : BSD3 -- portions Copyright (c) 2007, Galois Inc. -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A large and somewhat miscellaneous collection of utility functions used -- throughout the rest of the Cabal lib and in other tools that use the Cabal -- lib like @cabal-install@. It has a very simple set of logging actions. It -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. module Distribution.Utils.Generic ( -- * reading and writing files safely withFileContents, writeFileAtomic, -- * Unicode -- ** Conversions fromUTF8BS, fromUTF8LBS, toUTF8BS, toUTF8LBS, validateUTF8, -- ** File I/O readUTF8File, withUTF8FileContents, writeUTF8File, -- ** BOM ignoreBOM, -- ** Misc normaliseLineEndings, -- * generic utils dropWhileEndLE, takeWhileEndLE, equating, comparing, isInfixOf, intercalate, lowercase, isAscii, isAsciiAlpha, isAsciiAlphaNum, listUnion, listUnionRight, ordNub, ordNubBy, ordNubRight, safeHead, safeTail, safeLast, safeInit, unintersperse, wrapText, wrapLine, unfoldrM, spanMaybe, breakMaybe, unsnoc, unsnocNE, -- * Triples fstOf3, sndOf3, trdOf3, -- * FilePath stuff isAbsoluteOnAnyPlatform, isRelativeOnAnyPlatform, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.String import Data.Bits ((.&.), (.|.), shiftL) import Data.List ( isInfixOf ) import qualified Data.Set as Set import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import System.Directory ( removeFile, renameFile ) import System.FilePath ( (<.>), splitFileName ) import System.IO ( withFile, withBinaryFile , openBinaryTempFileWithDefaultPermissions , IOMode(ReadMode), hGetContents, hClose ) import qualified Control.Exception as Exception -- ----------------------------------------------------------------------------- -- Helper functions -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines . map (intercalate "\n" . map unwords . wrapLine 79 . words) . lines -- | Wraps a list of words to a list of lines of words of a particular width. wrapLine :: Int -> [String] -> [[String]] wrapLine width = wrap 0 [] where wrap :: Int -> [String] -> [String] -> [[String]] wrap 0 [] (w:ws) | length w + 1 > width = wrap (length w) [w] ws wrap col line (w:ws) | col + length w + 1 > width = reverse line : wrap 0 [] (w:ws) wrap col line (w:ws) = let col' = col + length w + 1 in wrap col' (w:line) ws wrap _ [] [] = [] wrap _ line [] = [reverse line] ----------------------------------- -- Safely reading and writing files -- | Gets the contents of a file, but guarantee that it gets closed. -- -- The file is read lazily but if it is not fully consumed by the action then -- the remaining input is truncated and the file is closed. -- withFileContents :: FilePath -> (String -> IO a) -> IO a withFileContents name action = withFile name ReadMode (\hnd -> hGetContents hnd >>= action) -- | Writes a file atomically. -- -- The file is either written successfully or an IO exception is raised and -- the original file is left unchanged. -- -- On windows it is not possible to delete a file that is open by a process. -- This case will give an IO exception but the atomic property is not affected. -- writeFileAtomic :: FilePath -> LBS.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) (\(tmpPath, handle) -> do LBS.hPut handle content hClose handle renameFile tmpPath targetPath) -- ------------------------------------------------------------ -- * Unicode stuff -- ------------------------------------------------------------ -- | Decode 'String' from UTF8-encoded 'BS.ByteString' -- -- Invalid data in the UTF8 stream (this includes code-points @U+D800@ -- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). -- fromUTF8BS :: SBS.ByteString -> String fromUTF8BS = decodeStringUtf8 . SBS.unpack -- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's -- fromUTF8LBS :: LBS.ByteString -> String fromUTF8LBS = decodeStringUtf8 . LBS.unpack -- | Encode 'String' to UTF8-encoded 'SBS.ByteString' -- -- Code-points in the @U+D800@-@U+DFFF@ range will be encoded -- as the replacement character (i.e. @U+FFFD@). -- toUTF8BS :: String -> SBS.ByteString toUTF8BS = SBS.pack . encodeStringUtf8 -- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's -- toUTF8LBS :: String -> LBS.ByteString toUTF8LBS = LBS.pack . encodeStringUtf8 -- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. validateUTF8 :: SBS.ByteString -> Maybe Int validateUTF8 = go 0 where go off bs = case SBS.uncons bs of Nothing -> Nothing Just (c, bs') | c <= 0x7F -> go (off + 1) bs' | c <= 0xBF -> Just off | c <= 0xDF -> twoBytes off c bs' | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) | otherwise -> Just off twoBytes off c0 bs = case SBS.uncons bs of Nothing -> Just off Just (c1, bs') | c1 .&. 0xC0 == 0x80 -> if d >= (0x80 :: Int) then go (off + 2) bs' else Just off | otherwise -> Just off where d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int moreBytes off 1 overlong cs' acc | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc = go (off + 1) cs' | otherwise = Just off moreBytes off byteCount overlong bs acc = case SBS.uncons bs of Just (cn, bs') | cn .&. 0xC0 == 0x80 -> moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) _ -> Just off -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input -- ignoreBOM :: String -> String ignoreBOM ('\xFEFF':string) = string ignoreBOM string = string -- | Reads a UTF8 encoded text file as a Unicode String -- -- Reads lazily using ordinary 'readFile'. -- readUTF8File :: FilePath -> IO String readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f -- | Reads a UTF8 encoded text file as a Unicode String -- -- Same behaviour as 'withFileContents'. -- withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a withUTF8FileContents name action = withBinaryFile name ReadMode (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) -- | Writes a Unicode String as a UTF8 encoded text file. -- -- Uses 'writeFileAtomic', so provides the same guarantees. -- writeUTF8File :: FilePath -> String -> IO () writeUTF8File path = writeFileAtomic path . toUTF8LBS -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String normaliseLineEndings [] = [] normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X normaliseLineEndings ( c :s) = c : normaliseLineEndings s -- ------------------------------------------------------------ -- * Common utils -- ------------------------------------------------------------ -- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but -- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this -- version is that the one in "Data.List" is strict in elements, but spine-lazy, -- while this one is spine-strict but lazy in elements. That's what @LE@ stands -- for - "lazy in elements". -- -- Example: -- -- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] -- *** Exception: Prelude.undefined -- ... -- -- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] -- [5,4,3] -- -- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] -- [5,4,3] -- -- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] -- *** Exception: Prelude.undefined -- ... -- dropWhileEndLE :: (a -> Bool) -> [a] -> [a] dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] -- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but -- is usually faster (as well as being easier to read). takeWhileEndLE :: (a -> Bool) -> [a] -> [a] takeWhileEndLE p = fst . foldr go ([], False) where go x (rest, done) | not done && p x = (x:rest, False) | otherwise = (rest, True) -- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of -- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's -- package. ordNub :: Ord a => [a] -> [a] ordNub = ordNubBy id -- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and -- takes the nub based on that key. ordNubBy :: Ord b => (a -> b) -> [a] -> [a] ordNubBy f l = go Set.empty l where go !_ [] = [] go !s (x:xs) | y `Set.member` s = go s xs | otherwise = let !s' = Set.insert y s in x : go s' xs where y = f x -- | Like "Data.List.union", but has @O(n log n)@ complexity instead of -- @O(n^2)@. listUnion :: (Ord a) => [a] -> [a] -> [a] listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) where aSet = Set.fromList a -- | A right-biased version of 'ordNub'. -- -- Example: -- -- >>> ordNub [1,2,1] :: [Int] -- [1,2] -- -- >>> ordNubRight [1,2,1] :: [Int] -- [2,1] -- ordNubRight :: (Ord a) => [a] -> [a] ordNubRight = fst . foldr go ([], Set.empty) where go x p@(l, s) = if x `Set.member` s then p else (x:l, Set.insert x s) -- | A right-biased version of 'listUnion'. -- -- Example: -- -- >>> listUnion [1,2,3,4,3] [2,1,1] -- [1,2,3,4,3] -- -- >>> listUnionRight [1,2,3,4,3] [2,1,1] -- [4,3,2,1,1] -- listUnionRight :: (Ord a) => [a] -> [a] -> [a] listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b where bSet = Set.fromList b -- | A total variant of 'head'. -- -- @since 3.2.0.0 safeHead :: [a] -> Maybe a safeHead [] = Nothing safeHead (x:_) = Just x -- | A total variant of 'tail'. -- -- @since 3.2.0.0 safeTail :: [a] -> [a] safeTail [] = [] safeTail (_:xs) = xs -- | A total variant of 'last'. -- -- @since 3.2.0.0 safeLast :: [a] -> Maybe a safeLast [] = Nothing safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) -- | A total variant of 'init'. -- -- @since 3.2.0.0 safeInit :: [a] -> [a] safeInit [] = [] safeInit [_] = [] safeInit (x:xs) = x : safeInit xs equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y -- | Lower case string -- -- >>> lowercase "Foobar" -- "foobar" lowercase :: String -> String lowercase = map toLower -- | Ascii characters isAscii :: Char -> Bool isAscii c = fromEnum c < 0x80 -- | Ascii letters. isAsciiAlpha :: Char -> Bool isAsciiAlpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') -- | Ascii letters and digits. -- -- >>> isAsciiAlphaNum 'a' -- True -- -- >>> isAsciiAlphaNum 'ä' -- False -- isAsciiAlphaNum :: Char -> Bool isAsciiAlphaNum c = isAscii c && isAlphaNum c unintersperse :: Char -> String -> [String] unintersperse mark = unfoldr unintersperse1 where unintersperse1 str | null str = Nothing | otherwise = let (this, rest) = break (== mark) str in Just (this, safeTail rest) -- | Like 'break', but with 'Maybe' predicate -- -- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] -- (["foo","bar"],Just (1,["2","quu"])) -- -- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] -- (["foo","bar"],Nothing) -- -- @since 2.2 -- breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) breakMaybe f = go id where go !acc [] = (acc [], Nothing) go !acc (x:xs) = case f x of Nothing -> go (acc . (x:)) xs Just b -> (acc [], Just (b, xs)) -- | Like 'span' but with 'Maybe' predicate -- -- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] -- ([1,3],[[],[4,5],[6,7]]) -- -- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] -- ([1,2],["foo"]) -- -- @since 2.2 -- spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) spanMaybe _ xs@[] = ([], xs) spanMaybe p xs@(x:xs') = case p x of Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) Nothing -> ([], xs) -- | 'unfoldr' with monadic action. -- -- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 -- [3,4,5,6,7] -- -- @since 2.2 -- unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] unfoldrM f = go where go b = do m <- f b case m of Nothing -> return [] Just (a, b') -> liftM (a :) (go b') -- | The opposite of 'snoc', which is the reverse of 'cons' -- -- Example: -- -- >>> unsnoc [1, 2, 3] -- Just ([1,2],3) -- -- >>> unsnoc [] -- Nothing -- -- @since 3.2.0.0 -- unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc (x:xs) = Just (unsnocNE (x :| xs)) -- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' -- -- Example: -- -- >>> unsnocNE (1 :| [2, 3]) -- ([1,2],3) -- -- >>> unsnocNE (1 :| []) -- ([],1) -- -- @since 3.2.0.0 -- unsnocNE :: NonEmpty a -> ([a], a) unsnocNE (x:|xs) = go x xs where go y [] = ([], y) go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) ------------------------------------------------------------------------------- -- Triples ------------------------------------------------------------------------------- -- | @since 3.4.0.0 fstOf3 :: (a,b,c) -> a fstOf3 (a,_,_) = a -- | @since 3.4.0.0 sndOf3 :: (a,b,c) -> b sndOf3 (_,b,_) = b -- | @since 3.4.0.0 trdOf3 :: (a,b,c) -> c trdOf3 (_,_,c) = c -- ------------------------------------------------------------ -- * FilePath stuff -- ------------------------------------------------------------ -- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like -- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have -- platform independent heuristics. -- The System.FilePath exists in two versions, Windows and Posix. The two -- versions don't agree on what is a relative path and we don't know if we're -- given Windows or Posix paths. -- This results in false positives when running on Posix and inspecting -- Windows paths, like the hackage server does. -- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False -- System.FilePath.Windows.isAbsolute \"/hello\" == False -- This means that we would treat paths that start with \"/\" to be absolute. -- On Posix they are indeed absolute, while on Windows they are not. -- -- The portable versions should be used when we might deal with paths that -- are from another OS than the host OS. For example, the Hackage Server -- deals with both Windows and Posix paths while performing the -- PackageDescription checks. In contrast, when we run 'cabal configure' we -- do expect the paths to be correct for our OS and we should not have to use -- the platform independent heuristics. isAbsoluteOnAnyPlatform :: FilePath -> Bool -- C:\\directory isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive -- UNC isAbsoluteOnAnyPlatform ('\\':'\\':_) = True -- Posix root isAbsoluteOnAnyPlatform ('/':_) = True isAbsoluteOnAnyPlatform _ = False -- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ isRelativeOnAnyPlatform :: FilePath -> Bool isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform -- $setup -- >>> import Data.Maybe -- >>> import Text.Read