{-# 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,

        -- * FilePath stuff
        isAbsoluteOnAnyPlatform,
        isRelativeOnAnyPlatform,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Utils.String

import Data.Bits ((.&.), (.|.), shiftL)
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, 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 :: String -> String
wrapText = [String] -> String
unlines
         ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
              ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
unwords
              ([[String]] -> [String])
-> (String -> [[String]]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [[String]]
wrapLine Int
79
              ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words)
         ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine :: Int -> [String] -> [[String]]
wrapLine Int
width = Int -> [String] -> [String] -> [[String]]
wrap Int
0 []
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap :: Int -> [String] -> [String] -> [[String]]
wrap Int
0   []   (String
w:[String]
ws)
          | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width
          = Int -> [String] -> [String] -> [[String]]
wrap (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w) [String
w] [String]
ws
        wrap Int
col [String]
line (String
w:[String]
ws)
          | Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width
          = [String] -> [String]
forall a. [a] -> [a]
reverse [String]
line [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String] -> [[String]]
wrap Int
0 [] (String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ws)
        wrap Int
col [String]
line (String
w:[String]
ws)
          = let col' :: Int
col' = Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
             in Int -> [String] -> [String] -> [[String]]
wrap Int
col' (String
wString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
line) [String]
ws
        wrap Int
_ []   [] = []
        wrap Int
_ [String]
line [] = [[String] -> [String]
forall a. [a] -> [a]
reverse [String]
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 :: String -> (String -> NoCallStackIO a) -> NoCallStackIO a
withFileContents String
name String -> NoCallStackIO a
action =
  String -> IOMode -> (Handle -> NoCallStackIO a) -> NoCallStackIO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
name IOMode
ReadMode
           (\Handle
hnd -> Handle -> IO String
hGetContents Handle
hnd IO String -> (String -> NoCallStackIO a) -> NoCallStackIO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> NoCallStackIO a
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 :: String -> ByteString -> NoCallStackIO ()
writeFileAtomic String
targetPath ByteString
content = do
  let (String
targetDir, String
targetFile) = String -> (String, String)
splitFileName String
targetPath
  IO (String, Handle)
-> ((String, Handle) -> NoCallStackIO ())
-> ((String, Handle) -> NoCallStackIO ())
-> NoCallStackIO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracketOnError
    (String -> String -> IO (String, Handle)
openBinaryTempFileWithDefaultPermissions String
targetDir (String -> IO (String, Handle)) -> String -> IO (String, Handle)
forall a b. (a -> b) -> a -> b
$ String
targetFile String -> String -> String
<.> String
"tmp")
    (\(String
tmpPath, Handle
handle) -> Handle -> NoCallStackIO ()
hClose Handle
handle NoCallStackIO () -> NoCallStackIO () -> NoCallStackIO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> NoCallStackIO ()
removeFile String
tmpPath)
    (\(String
tmpPath, Handle
handle) -> do
        Handle -> ByteString -> NoCallStackIO ()
BS.hPut Handle
handle ByteString
content
        Handle -> NoCallStackIO ()
hClose Handle
handle
        String -> String -> NoCallStackIO ()
renameFile String
tmpPath String
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 :: ByteString -> String
fromUTF8BS = [Word8] -> String
decodeStringUtf8 ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
SBS.unpack

-- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's
--
fromUTF8LBS :: BS.ByteString -> String
fromUTF8LBS :: ByteString -> String
fromUTF8LBS = [Word8] -> String
decodeStringUtf8 ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

-- | Encode 'String' to 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 :: String -> ByteString
toUTF8BS = [Word8] -> ByteString
SBS.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
encodeStringUtf8

-- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's
--
toUTF8LBS :: String -> BS.ByteString
toUTF8LBS :: String -> ByteString
toUTF8LBS = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
encodeStringUtf8

-- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.
validateUTF8 :: SBS.ByteString -> Maybe Int
validateUTF8 :: ByteString -> Maybe Int
validateUTF8 = Int -> ByteString -> Maybe Int
go Int
0 where
    go :: Int -> ByteString -> Maybe Int
go Int
off ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
SBS.uncons ByteString
bs of
        Maybe (Word8, ByteString)
Nothing -> Maybe Int
forall a. Maybe a
Nothing
        Just (Word8
c, ByteString
bs')
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7F -> Int -> ByteString -> Maybe Int
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
bs'
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xBF -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xDF -> Int -> Word8 -> ByteString -> Maybe Int
twoBytes Int
off Word8
c ByteString
bs'
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xEF -> Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes Int
off Int
3 Int
0x800     ByteString
bs' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF)
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xF7 -> Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes Int
off Int
4 Int
0x10000   ByteString
bs' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7)
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xFB -> Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes Int
off Int
5 Int
0x200000  ByteString
bs' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3)
            | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xFD -> Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes Int
off Int
6 Int
0x4000000 ByteString
bs' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x1)
            | Bool
otherwise -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off

    twoBytes :: Int -> Word8 -> ByteString -> Maybe Int
twoBytes Int
off Word8
c0 ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
SBS.uncons ByteString
bs of
        Maybe (Word8, ByteString)
Nothing        -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
        Just (Word8
c1, ByteString
bs')
            | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 ->
                if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
0x80 :: Int)
                then Int -> ByteString -> Maybe Int
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) ByteString
bs'
                else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
            | Bool
otherwise -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
          where
            d :: Int
d = (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x1F) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3F)

    moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int
    moreBytes :: Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes Int
off Int
1 Int
overlong ByteString
cs' Int
acc
      | Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc, Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF, Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xD800 Bool -> Bool -> Bool
|| Int
0xDFFF Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc
      = Int -> ByteString -> Maybe Int
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
cs'

      | Bool
otherwise
      = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off

    moreBytes Int
off Int
byteCount Int
overlong ByteString
bs Int
acc = case ByteString -> Maybe (Word8, ByteString)
SBS.uncons ByteString
bs of
        Just (Word8
cn, ByteString
bs') | Word8
cn Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 ->
            Int -> Int -> Int -> ByteString -> Int -> Maybe Int
moreBytes (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
byteCountInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
overlong ByteString
bs' ((Int
acc Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
cn Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3F)
        Maybe (Word8, ByteString)
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
off
        

-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input
--
ignoreBOM :: String -> String
ignoreBOM :: String -> String
ignoreBOM (Char
'\xFEFF':String
string) = String
string
ignoreBOM String
string            = String
string

-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Reads lazily using ordinary 'readFile'.
--
readUTF8File :: FilePath -> NoCallStackIO String
readUTF8File :: String -> IO String
readUTF8File String
f = (String -> String
ignoreBOM (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
fromUTF8LBS) (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
f

-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Same behaviour as 'withFileContents'.
--
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
withUTF8FileContents :: String -> (String -> IO a) -> IO a
withUTF8FileContents String
name String -> IO a
action =
  String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
name IOMode
ReadMode
    (\Handle
hnd -> Handle -> IO ByteString
BS.hGetContents Handle
hnd IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO a
String -> IO a
action (String -> IO a) -> (ByteString -> String) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ignoreBOM (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
fromUTF8LBS)

-- | Writes a Unicode String as a UTF8 encoded text file.
--
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
writeUTF8File :: FilePath -> String -> NoCallStackIO ()
writeUTF8File :: String -> String -> NoCallStackIO ()
writeUTF8File String
path = String -> ByteString -> NoCallStackIO ()
writeFileAtomic String
path (ByteString -> NoCallStackIO ())
-> (String -> ByteString) -> String -> NoCallStackIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word8]
encodeStringUtf8

-- | Fix different systems silly line ending conventions
normaliseLineEndings :: String -> String
normaliseLineEndings :: String -> String
normaliseLineEndings [] = []
normaliseLineEndings (Char
'\r':Char
'\n':String
s) = Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
normaliseLineEndings String
s -- windows
normaliseLineEndings (Char
'\r':String
s)      = Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
normaliseLineEndings String
s -- old OS X
normaliseLineEndings (  Char
c :String
s)      =   Char
c  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
normaliseLineEndings String
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 :: (a -> Bool) -> [a] -> [a]
dropWhileEndLE a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
r -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
r Bool -> Bool -> Bool
&& a -> Bool
p a
x then [] else a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
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 :: (a -> Bool) -> [a] -> [a]
takeWhileEndLE a -> Bool
p = ([a], Bool) -> [a]
forall a b. (a, b) -> a
fst (([a], Bool) -> [a]) -> ([a] -> ([a], Bool)) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ([a], Bool) -> ([a], Bool))
-> ([a], Bool) -> [a] -> ([a], Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> ([a], Bool) -> ([a], Bool)
go ([], Bool
False)
  where
    go :: a -> ([a], Bool) -> ([a], Bool)
go a
x ([a]
rest, Bool
done)
      | Bool -> Bool
not Bool
done Bool -> Bool -> Bool
&& a -> Bool
p a
x = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest, Bool
False)
      | Bool
otherwise = ([a]
rest, Bool
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 :: [a] -> [a]
ordNub = (a -> a) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubBy a -> a
forall a. a -> a
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 :: (a -> b) -> [a] -> [a]
ordNubBy a -> b
f [a]
l = Set b -> [a] -> [a]
go Set b
forall a. Set a
Set.empty [a]
l
  where
    go :: Set b -> [a] -> [a]
go !Set b
_ [] = []
    go !Set b
s (a
x:[a]
xs)
      | b
y b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
s = Set b -> [a] -> [a]
go Set b
s [a]
xs
      | Bool
otherwise        = let !s' :: Set b
s' = b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
y Set b
s
                            in a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set b -> [a] -> [a]
go Set b
s' [a]
xs
      where
        y :: b
y = a -> b
f a
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] -> [a] -> [a]
listUnion [a]
a [a]
b = [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. Ord a => [a] -> [a]
ordNub ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
aSet) [a]
b)
  where
    aSet :: Set a
aSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
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 :: [a] -> [a]
ordNubRight = ([a], Set a) -> [a]
forall a b. (a, b) -> a
fst (([a], Set a) -> [a]) -> ([a] -> ([a], Set a)) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ([a], Set a) -> ([a], Set a))
-> ([a], Set a) -> [a] -> ([a], Set a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> ([a], Set a) -> ([a], Set a)
forall a. Ord a => a -> ([a], Set a) -> ([a], Set a)
go ([], Set a
forall a. Set a
Set.empty)
  where
    go :: a -> ([a], Set a) -> ([a], Set a)
go a
x p :: ([a], Set a)
p@([a]
l, Set a
s) = if a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s then ([a], Set a)
p
                                        else (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
l, a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
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] -> [a] -> [a]
listUnionRight [a]
a [a]
b = [a] -> [a]
forall a. Ord a => [a] -> [a]
ordNubRight ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
bSet) [a]
a) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
b
  where
    bSet :: Set a
bSet = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
b

-- | A total variant of 'head'.
--
-- @since 3.2.0.0
safeHead :: [a] -> Maybe a
safeHead :: [a] -> Maybe a
safeHead []    = Maybe a
forall a. Maybe a
Nothing
safeHead (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

-- | A total variant of 'tail'.
--
-- @since 3.2.0.0
safeTail :: [a] -> [a]
safeTail :: [a] -> [a]
safeTail []     = []
safeTail (a
_:[a]
xs) = [a]
xs

-- | A total variant of 'last'.
--
-- @since 3.2.0.0
safeLast :: [a] -> Maybe a
safeLast :: [a] -> Maybe a
safeLast []     = Maybe a
forall a. Maybe a
Nothing
safeLast (a
x:[a]
xs) = a -> Maybe a
forall a. a -> Maybe a
Just ((a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a
_ a
a -> a
a) a
x [a]
xs)

-- | A total variant of 'init'.
--
-- @since 3.2.0.0
safeInit :: [a] -> [a]
safeInit :: [a] -> [a]
safeInit []     = []
safeInit [a
_]    = []
safeInit (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. [a] -> [a]
safeInit [a]
xs

equating :: Eq a => (b -> a) -> b -> b -> Bool
equating :: (b -> a) -> b -> b -> Bool
equating b -> a
p b
x b
y = b -> a
p b
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== b -> a
p b
y

-- | Lower case string
--
-- >>> lowercase "Foobar"
-- "foobar"
lowercase :: String -> String
lowercase :: String -> String
lowercase = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

-- | Ascii characters
isAscii :: Char -> Bool
isAscii :: Char -> Bool
isAscii Char
c = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80

-- | Ascii letters.
isAsciiAlpha :: Char -> Bool
isAsciiAlpha :: Char -> Bool
isAsciiAlpha Char
c = (Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')
    Bool -> Bool -> Bool
|| (Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z')

-- | Ascii letters and digits.
--
-- >>> isAsciiAlphaNum 'a'
-- True
--
-- >>> isAsciiAlphaNum 'ä'
-- False
--
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c

unintersperse :: Char -> String -> [String]
unintersperse :: Char -> String -> [String]
unintersperse Char
mark = (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr String -> Maybe (String, String)
unintersperse1 where
  unintersperse1 :: String -> Maybe (String, String)
unintersperse1 String
str
    | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str = Maybe (String, String)
forall a. Maybe a
Nothing
    | Bool
otherwise =
        let (String
this, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
mark) String
str in
        (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
this, String -> String
forall a. [a] -> [a]
safeTail String
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 :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a]))
breakMaybe a -> Maybe b
f = ([a] -> [a]) -> [a] -> ([a], Maybe (b, [a]))
forall c. ([a] -> c) -> [a] -> (c, Maybe (b, [a]))
go [a] -> [a]
forall a. a -> a
id where
    go :: ([a] -> c) -> [a] -> (c, Maybe (b, [a]))
go ![a] -> c
acc []     = ([a] -> c
acc [], Maybe (b, [a])
forall a. Maybe a
Nothing)
    go ![a] -> c
acc (a
x:[a]
xs) = case a -> Maybe b
f a
x of
        Maybe b
Nothing -> ([a] -> c) -> [a] -> (c, Maybe (b, [a]))
go ([a] -> c
acc ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [a]
xs
        Just b
b  -> ([a] -> c
acc [], (b, [a]) -> Maybe (b, [a])
forall a. a -> Maybe a
Just (b
b, [a]
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 :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe a -> Maybe b
_ xs :: [a]
xs@[] =  ([], [a]
xs)
spanMaybe a -> Maybe b
p xs :: [a]
xs@(a
x:[a]
xs') = case a -> Maybe b
p a
x of
    Just b
y  -> let ([b]
ys, [a]
zs) = (a -> Maybe b) -> [a] -> ([b], [a])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe a -> Maybe b
p [a]
xs' in (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
ys, [a]
zs)
    Maybe b
Nothing -> ([], [a]
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 :: (b -> m (Maybe (a, b))) -> b -> m [a]
unfoldrM b -> m (Maybe (a, b))
f = b -> m [a]
go where
    go :: b -> m [a]
go b
b = do
        Maybe (a, b)
m <- b -> m (Maybe (a, b))
f b
b
        case Maybe (a, b)
m of
            Maybe (a, b)
Nothing      -> [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just (a
a, b
b') -> ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (b -> m [a]
go b
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 :: [a] -> Maybe ([a], a)
unsnoc []     = Maybe ([a], a)
forall a. Maybe a
Nothing
unsnoc (a
x:[a]
xs) = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (NonEmpty a -> ([a], a)
forall a. NonEmpty a -> ([a], a)
unsnocNE (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
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 :: NonEmpty a -> ([a], a)
unsnocNE (a
x:|[a]
xs) = a -> [a] -> ([a], a)
forall a. a -> [a] -> ([a], a)
go a
x [a]
xs where
    go :: a -> [a] -> ([a], a)
go a
y []     = ([], a
y)
    go a
y (a
z:[a]
zs) = let ~([a]
ws, a
w) = a -> [a] -> ([a], a)
go a
z [a]
zs in (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ws, a
w)

-- ------------------------------------------------------------
-- * 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 :: String -> Bool
isAbsoluteOnAnyPlatform (Char
drive:Char
':':Char
'\\':String
_) = Char -> Bool
isAlpha Char
drive
isAbsoluteOnAnyPlatform (Char
drive:Char
':':Char
'/':String
_)  = Char -> Bool
isAlpha Char
drive
-- UNC
isAbsoluteOnAnyPlatform (Char
'\\':Char
'\\':String
_) = Bool
True
-- Posix root
isAbsoluteOnAnyPlatform (Char
'/':String
_) = Bool
True
isAbsoluteOnAnyPlatform String
_ = Bool
False

-- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@
isRelativeOnAnyPlatform :: FilePath -> Bool
isRelativeOnAnyPlatform :: String -> Bool
isRelativeOnAnyPlatform = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isAbsoluteOnAnyPlatform

-- $setup
-- >>> import Data.Maybe
-- >>> import Text.Read