{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
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 :: (a, a) -> a -> Bool
inRange (a
a,a
b) a
c = a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
a Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b
overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a)
overlap :: (a, a) -> (a, a) -> Maybe (a, a)
overlap (a
a,a
b) (a
c,a
d) =
if a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
c
then if a
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
d
then if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
c
then (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a,a
b)
else (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
c,a
b)
else if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
c
then (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a,a
d)
else (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
c,a
d)
else Maybe (a, a)
forall a. Maybe a
Nothing
addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a)
addToRange :: (a, a) -> a -> Maybe (a, a)
addToRange (a
a,a
b) a
c
| (a, a) -> a -> Bool
forall a. Ord a => (a, a) -> a -> Bool
inRange (a
a,a
b) a
c = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a,a
b)
| a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Enum a => a -> a
pred a
a = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
c,a
b)
| a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Enum a => a -> a
succ a
b = (a, a) -> Maybe (a, a)
forall a. a -> Maybe a
Just (a
a,a
c)
| Bool
otherwise = Maybe (a, a)
forall a. Maybe a
Nothing
increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a])
increasingSeq :: [a] -> ([a], [a])
increasingSeq [] = ([],[])
increasingSeq (a
x:[a]
xs) = [a] -> [a] -> ([a], [a])
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Enum a => a -> a
succ a
i
then [a] -> [a] -> ([a], [a])
go (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
is) [a]
ys
else ([a]
is, a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
go [a]
_ [a]
_ = [Char] -> ([a], [a])
forall a. HasCallStack => [Char] -> a
error [Char]
"Glob.increasingSeq :: internal error"
isLeft :: Either a b -> Bool
isLeft :: Either a b -> Bool
isLeft (Left a
_) = Bool
True
isLeft Either a b
_ = Bool
False
fromLeft :: Either a b -> a
fromLeft :: Either a b -> a
fromLeft (Left a
x) = a
x
fromLeft Either a b
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"fromLeft :: Right"
dropLeadingZeroes :: String -> String
dropLeadingZeroes :: [Char] -> [Char]
dropLeadingZeroes [Char]
s =
let x :: [Char]
x = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'0') [Char]
s
in if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x then [Char]
"0" else [Char]
x
pathParts :: FilePath -> [FilePath]
pathParts :: [Char] -> [[Char]]
pathParts [Char]
p = [Char]
p [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: let d :: [Char]
d = [Char] -> [Char]
dropDrive [Char]
p
in if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
d Bool -> Bool -> Bool
|| [Char]
d [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
p
then [Char] -> [[Char]]
f [Char]
d
else [Char]
d [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
f [Char]
d
where
f :: [Char] -> [[Char]]
f [] = []
f (Char
x:xs :: [Char]
xs@(Char
y:[Char]
_)) | Char -> Bool
isPathSeparator Char
x Bool -> Bool -> Bool
&& Char -> Bool
isPathSeparator Char
y = [Char] -> [[Char]]
f [Char]
xs
f (Char
x:[Char]
xs) =
if Char -> Bool
isPathSeparator Char
x
then [Char]
xs [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
f [Char]
xs
else [Char] -> [[Char]]
f [Char]
xs
doesDirectoryExist :: FilePath -> IO Bool
#if mingw32_HOST_OS
doesDirectoryExist = flip withTString $ \s -> do
a <- c_GetFileAttributes s
return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)
#else
doesDirectoryExist :: [Char] -> IO Bool
doesDirectoryExist [Char]
s =
Int -> (Ptr CStat -> IO Bool) -> IO Bool
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeof_stat ((Ptr CStat -> IO Bool) -> IO Bool)
-> (Ptr CStat -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CStat
p ->
[Char] -> (CString -> IO Bool) -> IO Bool
forall a. [Char] -> (CString -> IO a) -> IO a
withCString
(if [Char] -> Bool
isDrive [Char]
s
then [Char] -> [Char]
addTrailingPathSeparator [Char]
s
else [Char] -> [Char]
dropTrailingPathSeparator [Char]
s)
((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
then (CMode -> Bool) -> IO CMode -> IO Bool
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 Bool -> IO Bool
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 :: [Char] -> IO (DList [Char])
getRecursiveContents [Char]
dir =
(IO (DList [Char])
-> (IOException -> IO (DList [Char])) -> IO (DList [Char]))
-> (IOException -> IO (DList [Char]))
-> IO (DList [Char])
-> IO (DList [Char])
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (DList [Char])
-> (IOException -> IO (DList [Char])) -> IO (DList [Char])
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (\IOException
_ -> DList [Char] -> IO (DList [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (DList [Char] -> IO (DList [Char]))
-> DList [Char] -> IO (DList [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> DList [Char]
forall a. a -> DList a
DL.singleton [Char]
dir) (IO (DList [Char]) -> IO (DList [Char]))
-> IO (DList [Char]) -> IO (DList [Char])
forall a b. (a -> b) -> a -> b
$ do
[[Char]]
raw <- [Char] -> IO [[Char]]
getDirectoryContents [Char]
dir
let entries :: [[Char]]
entries = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
dir [Char] -> [Char] -> [Char]
</>) ([[Char]]
raw [[Char]] -> [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[Char]
".",[Char]
".."])
([[Char]]
dirs,[[Char]]
files) <- ([Char] -> IO Bool) -> [[Char]] -> IO ([[Char]], [[Char]])
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM [Char] -> IO Bool
doesDirectoryExist [[Char]]
entries
[DList [Char]]
subs <- IO [DList [Char]] -> IO [DList [Char]]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [DList [Char]] -> IO [DList [Char]])
-> ([[Char]] -> IO [DList [Char]]) -> [[Char]] -> IO [DList [Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO (DList [Char])) -> [[Char]] -> IO [DList [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO (DList [Char])
getRecursiveContents ([[Char]] -> IO [DList [Char]]) -> [[Char]] -> IO [DList [Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
dirs
DList [Char] -> IO (DList [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return(DList [Char] -> IO (DList [Char]))
-> DList [Char] -> IO (DList [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> DList [Char] -> DList [Char]
forall a. a -> DList a -> DList a
DL.cons [Char]
dir ([[Char]] -> DList [Char]
forall a. [a] -> DList a
DL.fromList [[Char]]
files DList [Char] -> DList [Char] -> DList [Char]
forall a. DList a -> DList a -> DList a
`DL.append` [DList [Char]] -> DList [Char]
forall a. [DList a] -> DList a
DL.concat [DList [Char]]
subs)
partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
p_ = (([a], [a]) -> a -> m ([a], [a]))
-> ([a], [a]) -> [a] -> m ([a], [a])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((a -> m Bool) -> ([a], [a]) -> a -> m ([a], [a])
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 m Bool -> (Bool -> m ([a], [a])) -> m ([a], [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
if Bool
b
then ([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ts, [a]
fs)
else ([a], [a]) -> m ([a], [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
ts, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
fs)
partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a)
partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a)
partitionDL a -> Bool
p_ = (a -> (DList a, DList a) -> (DList a, DList a))
-> (DList a, DList a) -> DList a -> (DList a, DList a)
forall a b. (a -> b -> b) -> b -> DList a -> b
DL.foldr ((a -> Bool) -> a -> (DList a, DList a) -> (DList a, DList a)
forall a.
(a -> Bool) -> a -> (DList a, DList a) -> (DList a, DList a)
f a -> Bool
p_) (DList a
forall a. DList a
DL.empty,DList a
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 (a -> DList a -> DList a
forall a. a -> DList a -> DList a
DL.cons a
x DList a
ts, DList a
fs)
else (DList a
ts, a -> DList a -> DList a
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 :: DList a -> DList a
tailDL = [a] -> DList a
forall a. [a] -> DList a
DL.fromList ([a] -> DList a) -> (DList a -> [a]) -> DList a -> DList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList a -> [a]
forall a. DList a -> [a]
DL.tail
#else
tailDL = DL.tail
#endif
nubOrd :: Ord a => [a] -> [a]
nubOrd :: [a] -> [a]
nubOrd = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty
where
go :: Set a -> [a] -> [a]
go Set a
_ [] = []
go Set a
set (a
x:[a]
xs) =
if a -> Set a -> Bool
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
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 :: IO a -> (IOException -> IO a) -> IO a
catchIO = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch