Skip to content
GitLab
Commit 57b74d75 authored by John Ericson's avatar John Ericson
Browse files

Move non-Cabal-specific parts of Distribution.Simple.Utils out... 

...into Distribution.Utils.Generic. Distribution.Simple.Utils moved items.
parent 07b4b125
Hide whitespace changes
Inline Side-by-side
Cabal/Cabal.cabal
View file @ 57b74d75
......@@ -235,6 +235,7 @@ library
Distribution.Types.ComponentRequestedSpec
Distribution.Types.TargetInfo
Distribution.Types.UnqualComponentName
Distribution.Utils.Generic
Distribution.Utils.NubList
Distribution.Utils.ShortText
Distribution.Utils.Progress
......
Cabal/Distribution/ParseUtils.hs
View file @ 57b74d75
......@@ -51,7 +51,7 @@ import qualified Distribution.Compat.MonadFail as Fail
import Distribution.Compat.ReadP as ReadP hiding (get)
import Distribution.ReadE
import Distribution.Text
import Distribution.Simple.Utils
import Distribution.Utils.Generic
import Distribution.PrettyUtils
import Language.Haskell.Extension
......
Cabal/Distribution/Simple/Utils.hs
View file @ 57b74d75
......@@ -159,8 +159,8 @@ import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Text
import Distribution.Utils.String
--import Distribution.Package
import Distribution.Utils.Generic
import Distribution.Package
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
......@@ -186,19 +186,9 @@ import qualified Paths_Cabal (version)
import Control.Concurrent.MVar
( newEmptyMVar, putMVar, takeMVar )
import Data.Bits
( Bits((.|.), (.&.), shiftL, shiftR) )
import Data.List
( isInfixOf )
import Data.Typeable
( cast )
import Data.Ord
( comparing )
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import qualified Data.Set as Set
import qualified Data.ByteString as SBS
import System.Directory
( Permissions(executable), getDirectoryContents, getPermissions
......@@ -214,11 +204,10 @@ import System.FilePath
, splitExtension, splitExtensions, splitDirectories
, searchPathSeparator )
import System.Directory
( createDirectory, renameFile, removeDirectoryRecursive )
( createDirectory, removeDirectoryRecursive )
import System.IO
( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions
, IOMode(ReadMode), hSetBinaryMode
, hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush
, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
......@@ -371,8 +360,7 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do
hPutCallStackPrefix stdout verbosity
putStr msg
-- PackageIdentifier
setupMessage :: Text a => Verbosity -> String -> a -> IO ()
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid = withFrozenCallStack $ do
notice verbosity (msg ++ ' ': display pkgid ++ "...")
......@@ -426,37 +414,12 @@ handleDoesNotExist e =
-- -----------------------------------------------------------------------------
-- 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 text unless the @+nowrap@ verbosity flag is active
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity verb
| isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF
| otherwise = wrapText
-- | 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]
-- -----------------------------------------------------------------------------
-- rawSystem variants
maybeExit :: IO ExitCode -> IO ()
......@@ -1211,35 +1174,6 @@ withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $
-----------------------------------
-- 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 -> NoCallStackIO a) -> NoCallStackIO a
withFileContents name action =
Exception.bracket (openFile name ReadMode) hClose
(\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 -> BS.ByteString -> NoCallStackIO ()
writeFileAtomic targetPath content = do
let (targetDir, targetFile) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
(\(tmpPath, handle) -> do
BS.hPut handle content
hClose handle
renameFile tmpPath targetPath)
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
......@@ -1355,262 +1289,3 @@ findHookedPackageDesc dir = do
buildInfoExt :: String
buildInfoExt = ".buildinfo"
-- ------------------------------------------------------------
-- * Unicode stuff
-- ------------------------------------------------------------
-- This is a modification of the UTF8 code from gtk2hs and the
-- utf8-string package.
fromUTF8 :: String -> String
fromUTF8 [] = []
fromUTF8 (c:cs)
| c <= '\x7F' = c : fromUTF8 cs
| c <= '\xBF' = replacementChar : fromUTF8 cs
| c <= '\xDF' = twoBytes c cs
| c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF)
| c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7)
| c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3)
| c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)
| otherwise = replacementChar : fromUTF8 cs
where
twoBytes c0 (c1:cs')
| ord c1 .&. 0xC0 == 0x80
= let d = ((ord c0 .&. 0x1F) `shiftL` 6)
.|. (ord c1 .&. 0x3F)
in if d >= 0x80
then chr d : fromUTF8 cs'
else replacementChar : fromUTF8 cs'
twoBytes _ cs' = replacementChar : fromUTF8 cs'
moreBytes :: Int -> Int -> [Char] -> Int -> [Char]
moreBytes 1 overlong cs' acc
| overlong <= acc && acc <= 0x10FFFF
&& (acc < 0xD800 || 0xDFFF < acc)
&& (acc < 0xFFFE || 0xFFFF < acc)
= chr acc : fromUTF8 cs'
| otherwise
= replacementChar : fromUTF8 cs'
moreBytes byteCount overlong (cn:cs') acc
| ord cn .&. 0xC0 == 0x80
= moreBytes (byteCount-1) overlong cs'
((acc `shiftL` 6) .|. ord cn .&. 0x3F)
moreBytes _ _ cs' _
= replacementChar : fromUTF8 cs'
replacementChar = '\xfffd'
fromUTF8BS :: SBS.ByteString -> String
fromUTF8BS = decodeStringUtf8 . SBS.unpack
fromUTF8LBS :: BS.ByteString -> String
fromUTF8LBS = decodeStringUtf8 . BS.unpack
toUTF8 :: String -> String
toUTF8 [] = []
toUTF8 (c:cs)
| c <= '\x07F' = c
: toUTF8 cs
| c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))
: chr (0x80 .|. (w .&. 0x3F))
: toUTF8 cs
| c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12))
: chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))
: chr (0x80 .|. (w .&. 0x3F))
: toUTF8 cs
| otherwise = chr (0xf0 .|. (w `shiftR` 18))
: chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F))
: chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))
: chr (0x80 .|. (w .&. 0x3F))
: toUTF8 cs
where w = ord c
-- | Whether BOM is at the beginning of the input
startsWithBOM :: String -> Bool
startsWithBOM ('\xFEFF':_) = True
startsWithBOM _ = False
-- | Check whether a file has Unicode byte order mark (BOM).
fileHasBOM :: FilePath -> NoCallStackIO Bool
fileHasBOM f = fmap (startsWithBOM . fromUTF8)
. hGetContents =<< openBinaryFile f ReadMode
-- | 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 -> NoCallStackIO String
readUTF8File f = fmap (ignoreBOM . fromUTF8)
. hGetContents =<< openBinaryFile f ReadMode
-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Same behaviour as 'withFileContents'.
--
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
withUTF8FileContents name action =
Exception.bracket
(openBinaryFile name ReadMode)
hClose
(\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)
-- | Writes a Unicode String as a UTF8 encoded text file.
--
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
writeUTF8File :: FilePath -> String -> NoCallStackIO ()
writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8
-- | 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:
--
-- @
-- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]
-- *** Exception: Prelude.undefined
-- > tail $ 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
-- <http://github.com/nh2/haskell-ordnub ordnub> package.
ordNub :: (Ord a) => [a] -> [a]
ordNub l = go Set.empty l
where
go _ [] = []
go s (x:xs) = if x `Set.member` s then go s xs
else x : go (Set.insert x s) xs
-- | 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]
-- [1,2]
-- > ordNubRight [1,2,1]
-- [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 'tail'.
safeTail :: [a] -> [a]
safeTail [] = []
safeTail (_:xs) = xs
equating :: Eq a => (b -> a) -> b -> b -> Bool
equating p x y = p x == p y
lowercase :: String -> String
lowercase = map toLower
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)
-- ------------------------------------------------------------
-- * 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
Cabal/Distribution/Utils/Generic.hs 0 → 100644
View file @ 57b74d75
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- 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
fromUTF8,
fromUTF8BS,
fromUTF8LBS,
toUTF8,
readUTF8File,
withUTF8FileContents,
writeUTF8File,
normaliseLineEndings,
-- * BOM
startsWithBOM,
fileHasBOM,
ignoreBOM,
-- * generic utils
dropWhileEndLE,
takeWhileEndLE,
equating,
comparing,
isInfixOf,
intercalate,
lowercase,
listUnion,
listUnionRight,
ordNub,
ordNubRight,
safeTail,
unintersperse,
wrapText,
wrapLine,
-- * FilePath stuff
isAbsoluteOnAnyPlatform,
isRelativeOnAnyPlatform,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.String
import Data.Bits
( Bits((.|.), (.&.), shiftL, shiftR) )
import Data.List
( isInfixOf )
import Data.Ord
( comparing )
import qualified Data.ByteString.Lazy as BS
import qualified Data.Set as Set
import qualified Data.ByteString as SBS
import System.Directory
( removeFile )
import System.FilePath
( (<.>), splitFileName )
import System.Directory
( renameFile )
import System.IO
( openFile, openBinaryFile, 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 -> NoCallStackIO a) -> NoCallStackIO a
withFileContents name action =
Exception.bracket (openFile name ReadMode) hClose
(\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 -> BS.ByteString -> NoCallStackIO ()
writeFileAtomic targetPath content = do
let (targetDir, targetFile) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
(\(tmpPath, handle) -> do
BS.hPut handle content
hClose handle
renameFile tmpPath targetPath)
-- ------------------------------------------------------------
-- * Unicode stuff
-- ------------------------------------------------------------
-- This is a modification of the UTF8 code from gtk2hs and the
-- utf8-string package.
fromUTF8 :: String -> String
fromUTF8 [] = []
fromUTF8 (c:cs)
| c <= '\x7F' = c : fromUTF8 cs
| c <= '\xBF' = replacementChar : fromUTF8 cs
| c <= '\xDF' = twoBytes c cs
| c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF)
| c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7)
| c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3)
| c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)
| otherwise = replacementChar : fromUTF8 cs
where
twoBytes c0 (c1:cs')
| ord c1 .&. 0xC0 == 0x80
= let d = ((ord c0 .&. 0x1F) `shiftL` 6)
.|. (ord c1 .&. 0x3F)
in if d >= 0x80
then chr d : fromUTF8 cs'
else replacementChar : fromUTF8 cs'
twoBytes _ cs' = replacementChar : fromUTF8 cs'
moreBytes :: Int -> Int -> [Char] -> Int -> [Char]
moreBytes 1 overlong cs' acc
| overlong <= acc && acc <= 0x10FFFF
&& (acc < 0xD800 || 0xDFFF < acc)
&& (acc < 0xFFFE || 0xFFFF < acc)
= chr acc : fromUTF8 cs'
| otherwise
= replacementChar : fromUTF8 cs'
moreBytes byteCount overlong (cn:cs') acc
| ord cn .&. 0xC0 == 0x80
= moreBytes (byteCount-1) overlong cs'
((acc `shiftL` 6) .|. ord cn .&. 0x3F)
moreBytes _ _ cs' _
= replacementChar : fromUTF8 cs'