{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-- File created: 2008-10-10 13:40:35


module System.FilePath.Glob.Utils
   ( isLeft, fromLeft
   , increasingSeq
   , addToRange, inRange, overlap
   , dropLeadingZeroes
   , pathParts
   , nubOrd
   , partitionDL, tailDL
   , getRecursiveContents
   , catchIO
   ) where

import Control.Monad    (foldM)
import qualified Control.Exception as E
import Data.List        ((\\))
import qualified Data.DList as DL
import Data.DList       (DList)
import qualified Data.Set as Set
import System.Directory (getDirectoryContents)
import System.FilePath  ((</>), isPathSeparator, dropDrive)
import System.IO.Unsafe (unsafeInterleaveIO)

#if mingw32_HOST_OS
import Data.Bits          ((.&.))
import System.Win32.Types (withTString)
import System.Win32.File  (FileAttributeOrFlag, fILE_ATTRIBUTE_DIRECTORY)
import System.Win32.String (LPCTSTR)
#else
import Foreign.C.String      (withCString)
import Foreign.Marshal.Alloc (allocaBytes)
import System.FilePath
   (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator)
import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode)
#endif

inRange :: Ord a => (a,a) -> a -> Bool
inRange :: forall a. Ord a => (a, a) -> a -> Bool
inRange (a
a,a
b) a
c = a
c forall a. Ord a => a -> a -> Bool
>= a
a Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
b

-- returns Just (a range which covers both given ranges) or Nothing if they are

-- disjoint.

--

-- Assumes that the ranges are in the correct order, i.e. (fst x < snd x).

overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a)
overlap :: forall a. Ord a => (a, a) -> (a, a) -> Maybe (a, a)
overlap (a
a,a
b) (a
c,a
d) =
   if a
b forall a. Ord a => a -> a -> Bool
>= a
c
      then if a
b forall a. Ord a => a -> a -> Bool
>= a
d
              then if a
a forall a. Ord a => a -> a -> Bool
<= a
c
                      then forall a. a -> Maybe a
Just (a
a,a
b)
                      else forall a. a -> Maybe a
Just (a
c,a
b)
              else if a
a forall a. Ord a => a -> a -> Bool
<= a
c
                      then forall a. a -> Maybe a
Just (a
a,a
d)
                      else forall a. a -> Maybe a
Just (a
c,a
d)
      else forall a. Maybe a
Nothing

addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a)
addToRange :: forall a. (Ord a, Enum a) => (a, a) -> a -> Maybe (a, a)
addToRange (a
a,a
b) a
c
   | forall a. Ord a => (a, a) -> a -> Bool
inRange (a
a,a
b) a
c = forall a. a -> Maybe a
Just (a
a,a
b)
   | a
c forall a. Eq a => a -> a -> Bool
== forall a. Enum a => a -> a
pred a
a     = forall a. a -> Maybe a
Just (a
c,a
b)
   | a
c forall a. Eq a => a -> a -> Bool
== forall a. Enum a => a -> a
succ a
b     = forall a. a -> Maybe a
Just (a
a,a
c)
   | Bool
otherwise       = forall a. Maybe a
Nothing

-- fst of result is in reverse order so that:

--

-- If x = fst (increasingSeq (a:xs)), then

-- x == reverse [a .. head x]

increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a])
increasingSeq :: forall a. (Eq a, Enum a) => [a] -> ([a], [a])
increasingSeq []     = ([],[])
increasingSeq (a
x:[a]
xs) = forall {a}. (Eq a, Enum a) => [a] -> [a] -> ([a], [a])
go [a
x] [a]
xs
 where
   go :: [a] -> [a] -> ([a], [a])
go [a]
is       []     = ([a]
is,[])
   go is :: [a]
is@(a
i:[a]
_) (a
y:[a]
ys) =
      if a
y forall a. Eq a => a -> a -> Bool
== forall a. Enum a => a -> a
succ a
i
         then [a] -> [a] -> ([a], [a])
go (a
yforall a. a -> [a] -> [a]
:[a]
is) [a]
ys
         else ([a]
is, a
yforall a. a -> [a] -> [a]
:[a]
ys)
   go [a]
_ [a]
_ = forall a. HasCallStack => FilePath -> a
error FilePath
"Glob.increasingSeq :: internal error"

isLeft :: Either a b -> Bool
isLeft :: forall a b. Either a b -> Bool
isLeft (Left a
_) = Bool
True
isLeft Either a b
_        = Bool
False

fromLeft :: Either a b -> a
fromLeft :: forall a b. Either a b -> a
fromLeft (Left a
x) = a
x
fromLeft Either a b
_        = forall a. HasCallStack => FilePath -> a
error FilePath
"fromLeft :: Right"

dropLeadingZeroes :: String -> String
dropLeadingZeroes :: FilePath -> FilePath
dropLeadingZeroes FilePath
s =
   let x :: FilePath
x = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'0') FilePath
s
    in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
x then FilePath
"0" else FilePath
x

-- foo/bar/baz -> [foo/bar/baz,bar/baz,baz]

pathParts :: FilePath -> [FilePath]
pathParts :: FilePath -> [FilePath]
pathParts FilePath
p = FilePath
p forall a. a -> [a] -> [a]
: let d :: FilePath
d = FilePath -> FilePath
dropDrive FilePath
p
                   in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
d Bool -> Bool -> Bool
|| FilePath
d forall a. Eq a => a -> a -> Bool
== FilePath
p
                         then     FilePath -> [FilePath]
f FilePath
d
                         else FilePath
d forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
f FilePath
d
 where
   f :: FilePath -> [FilePath]
f []  = []
   f (Char
x:xs :: FilePath
xs@(Char
y:FilePath
_)) | Char -> Bool
isPathSeparator Char
x Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
y = FilePath -> [FilePath]
f FilePath
xs
   f (Char
x:FilePath
xs) =
      if Char -> Bool
isPathSeparator Char
x
         then FilePath
xs forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
f FilePath
xs
         else      FilePath -> [FilePath]
f FilePath
xs

-- Significantly speedier than System.Directory.doesDirectoryExist.

doesDirectoryExist :: FilePath -> IO Bool
#if mingw32_HOST_OS
-- This one allocates more memory since it has to do a UTF-16 conversion, but

-- that can't really be helped: the below version is locale-dependent.

doesDirectoryExist = flip withTString $ \s -> do
   a <- c_GetFileAttributes s
   return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)
#else
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist FilePath
s =
   forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_stat forall a b. (a -> b) -> a -> b
$ \Ptr CStat
p ->
      forall a. FilePath -> (CString -> IO a) -> IO a
withCString
         (if FilePath -> Bool
isDrive FilePath
s
             then FilePath -> FilePath
addTrailingPathSeparator FilePath
s
             else FilePath -> FilePath
dropTrailingPathSeparator FilePath
s)
         forall a b. (a -> b) -> a -> b
$ \CString
c -> do
            CInt
st <- CString -> Ptr CStat -> IO CInt
lstat CString
c Ptr CStat
p
            if CInt
st forall a. Eq a => a -> a -> Bool
== CInt
0
               then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CMode -> Bool
s_isdir (Ptr CStat -> IO CMode
st_mode Ptr CStat
p)
               else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
#endif

#if mingw32_HOST_OS
#if defined(i386_HOST_ARCH)
foreign import stdcall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag
#elif defined(x86_64_HOST_ARCH)
foreign import ccall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag
#else
#error Unknown mingw32 arch
#endif
#endif

getRecursiveContents :: FilePath -> IO (DList FilePath)
getRecursiveContents :: FilePath -> IO (DList FilePath)
getRecursiveContents FilePath
dir =
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (\IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> DList a
DL.singleton FilePath
dir) forall a b. (a -> b) -> a -> b
$ do

      [FilePath]
raw <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
dir

      let entries :: [FilePath]
entries = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
dir FilePath -> FilePath -> FilePath
</>) ([FilePath]
raw forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath
".",FilePath
".."])
      ([FilePath]
dirs,[FilePath]
files) <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM FilePath -> IO Bool
doesDirectoryExist [FilePath]
entries

      [DList FilePath]
subs <- forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (DList FilePath)
getRecursiveContents forall a b. (a -> b) -> a -> b
$ [FilePath]
dirs

      forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ forall a. a -> DList a -> DList a
DL.cons FilePath
dir (forall a. [a] -> DList a
DL.fromList [FilePath]
files forall a. DList a -> DList a -> DList a
`DL.append` forall a. [DList a] -> DList a
DL.concat [DList FilePath]
subs)

partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
p_ = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall {m :: * -> *} {a}.
Monad m =>
(a -> m Bool) -> ([a], [a]) -> a -> m ([a], [a])
f a -> m Bool
p_) ([],[])
 where
   f :: (a -> m Bool) -> ([a], [a]) -> a -> m ([a], [a])
f a -> m Bool
p ([a]
ts,[a]
fs) a
x = a -> m Bool
p a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
      if Bool
b
         then forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:[a]
ts, [a]
fs)
         else forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
ts, a
xforall a. a -> [a] -> [a]
:[a]
fs)

partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a)
partitionDL :: forall a. (a -> Bool) -> DList a -> (DList a, DList a)
partitionDL a -> Bool
p_ = forall a b. (a -> b -> b) -> b -> DList a -> b
DL.foldr (forall {a}.
(a -> Bool) -> a -> (DList a, DList a) -> (DList a, DList a)
f a -> Bool
p_) (forall a. DList a
DL.empty,forall a. DList a
DL.empty)
 where
   f :: (a -> Bool) -> a -> (DList a, DList a) -> (DList a, DList a)
f a -> Bool
p a
x (DList a
ts,DList a
fs) =
      if a -> Bool
p a
x
         then (forall a. a -> DList a -> DList a
DL.cons a
x DList a
ts, DList a
fs)
         else (DList a
ts, forall a. a -> DList a -> DList a
DL.cons a
x DList a
fs)

tailDL :: DList a -> DList a
#if MIN_VERSION_dlist(1,0,0)
tailDL :: forall a. DList a -> DList a
tailDL = forall a. [a] -> DList a
DL.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DList a -> [a]
DL.tail
#else
tailDL = DL.tail
#endif

nubOrd :: Ord a => [a] -> [a]
nubOrd :: forall a. Ord a => [a] -> [a]
nubOrd = forall {a}. Ord a => Set a -> [a] -> [a]
go forall a. Set a
Set.empty
 where
   go :: Set a -> [a] -> [a]
go Set a
_ [] = []
   go Set a
set (a
x:[a]
xs) =
      if forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
set
         then Set a -> [a] -> [a]
go Set a
set [a]
xs
         else a
x forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
set) [a]
xs

catchIO :: IO a -> (E.IOException -> IO a) -> IO a
catchIO :: forall a. IO a -> (IOException -> IO a) -> IO a
catchIO = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch