{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Utils.Generic
-- 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 Distribution.Compat.Prelude
import Prelude ()

import Distribution.Utils.String

import Data.Bits (shiftL, (.&.), (.|.))
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import Data.List
  ( isInfixOf
  )
import qualified Data.Set as Set

import qualified Control.Exception as Exception
import System.Directory
  ( removeFile
  , renameFile
  )
import System.FilePath
  ( splitFileName
  , (<.>)
  )
import System.IO
  ( IOMode (ReadMode)
  , hClose
  , hGetContents
  , openBinaryTempFileWithDefaultPermissions
  , withBinaryFile
  , withFile
  )

-- -----------------------------------------------------------------------------
-- 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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
w String -> [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 a. [a] -> 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
w String -> [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 -> IO a) -> IO a
withFileContents :: forall a. String -> (String -> IO a) -> IO a
withFileContents String
name String -> IO a
action =
  String -> IOMode -> (Handle -> IO a) -> IO 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 -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO 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 -> LBS.ByteString -> IO ()
writeFileAtomic :: String -> ByteString -> IO ()
writeFileAtomic String
targetPath ByteString
content = do
  let (String
targetDir, String
targetFile) = String -> (String, String)
splitFileName String
targetPath
  IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO ())
-> IO ()
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 -> IO ()
hClose Handle
handle IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
removeFile String
tmpPath)
    ( \(String
tmpPath, Handle
handle) -> do
        Handle -> ByteString -> IO ()
LBS.hPut Handle
handle ByteString
content
        Handle -> IO ()
hClose Handle
handle
        String -> String -> IO ()
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 :: LBS.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]
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 :: 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 -> LBS.ByteString
toUTF8LBS :: String -> ByteString
toUTF8LBS = [Word8] -> ByteString
LBS.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
byteCount Int -> 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 -> IO 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
LBS.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 :: forall a. 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
LBS.hGetContents Handle
hnd IO ByteString -> (ByteString -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 -> IO ()
writeUTF8File :: String -> String -> IO ()
writeUTF8File String
path = String -> ByteString -> IO ()
writeFileAtomic String
path (ByteString -> IO ()) -> (String -> ByteString) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8LBS

-- | 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 :: forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x [a]
r -> if [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
r Bool -> Bool -> Bool
&& a -> Bool
p a
x then [] else a
x a -> [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 :: forall a. (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 a b. (a -> b -> b) -> b -> [a] -> b
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
x a -> [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 :: forall a. Ord a => [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 :: forall b a. Ord b => (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 :: forall a. Ord a => [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 :: forall a. Ord a => [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 a b. (a -> b -> b) -> b -> [a] -> b
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
x a -> [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 :: forall a. Ord a => [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 :: forall a. [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 :: forall a. [a] -> [a]
safeTail [] = []
safeTail (a
_ : [a]
xs) = [a]
xs

-- | A total variant of 'last'.
--
-- @since 3.2.0.0
safeLast :: [a] -> Maybe a
safeLast :: forall a. [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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall a. [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 :: forall a b. Eq a => (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 a. [a] -> 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 :: forall a b. (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
x a -> [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 :: forall a b. (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 :: forall (m :: * -> *) b a.
Monad m =>
(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 a. 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 :: forall a. [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 :: forall a. 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)

-------------------------------------------------------------------------------
-- Triples
-------------------------------------------------------------------------------

-- | @since 3.4.0.0
fstOf3 :: (a, b, c) -> a
fstOf3 :: forall a b c. (a, b, c) -> a
fstOf3 (a
a, b
_, c
_) = a
a

-- | @since 3.4.0.0
sndOf3 :: (a, b, c) -> b
sndOf3 :: forall a b c. (a, b, c) -> b
sndOf3 (a
_, b
b, c
_) = b
b

-- | @since 3.4.0.0
trdOf3 :: (a, b, c) -> c
trdOf3 :: forall a b c. (a, b, c) -> c
trdOf3 (a
_, b
_, c
c) = 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 :: 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