1{-# LANGUAGE CPP #-} 2-- File created: 2008-10-10 13:40:35 3 4module System.FilePath.Glob.Utils 5 ( isLeft, fromLeft 6 , increasingSeq 7 , addToRange, inRange, overlap 8 , dropLeadingZeroes 9 , pathParts 10 , nubOrd 11 , partitionDL, tailDL 12 , getRecursiveContents 13 , catchIO 14 ) where 15 16import Control.Monad (foldM) 17import qualified Control.Exception as E 18import Data.List ((\\)) 19import qualified Data.DList as DL 20import Data.DList (DList) 21import qualified Data.Set as Set 22import System.Directory (getDirectoryContents) 23import System.FilePath ((</>), isPathSeparator, dropDrive) 24import System.IO.Unsafe (unsafeInterleaveIO) 25 26#if mingw32_HOST_OS 27import Data.Bits ((.&.)) 28import System.Win32.Types (withTString) 29import System.Win32.File (c_GetFileAttributes, fILE_ATTRIBUTE_DIRECTORY) 30#else 31import Foreign.C.String (withCString) 32import Foreign.Marshal.Alloc (allocaBytes) 33import System.FilePath 34 (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator) 35import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode) 36#endif 37 38inRange :: Ord a => (a,a) -> a -> Bool 39inRange (a,b) c = c >= a && c <= b 40 41-- returns Just (a range which covers both given ranges) or Nothing if they are 42-- disjoint. 43-- 44-- Assumes that the ranges are in the correct order, i.e. (fst x < snd x). 45overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a) 46overlap (a,b) (c,d) = 47 if b >= c 48 then if b >= d 49 then if a <= c 50 then Just (a,b) 51 else Just (c,b) 52 else if a <= c 53 then Just (a,d) 54 else Just (c,d) 55 else Nothing 56 57addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a) 58addToRange (a,b) c 59 | inRange (a,b) c = Just (a,b) 60 | c == pred a = Just (c,b) 61 | c == succ b = Just (a,c) 62 | otherwise = Nothing 63 64-- fst of result is in reverse order so that: 65-- 66-- If x = fst (increasingSeq (a:xs)), then 67-- x == reverse [a .. head x] 68increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a]) 69increasingSeq [] = ([],[]) 70increasingSeq (x:xs) = go [x] xs 71 where 72 go is [] = (is,[]) 73 go is@(i:_) (y:ys) = 74 if y == succ i 75 then go (y:is) ys 76 else (is, y:ys) 77 go _ _ = error "Glob.increasingSeq :: internal error" 78 79isLeft :: Either a b -> Bool 80isLeft (Left _) = True 81isLeft _ = False 82 83fromLeft :: Either a b -> a 84fromLeft (Left x) = x 85fromLeft _ = error "fromLeft :: Right" 86 87dropLeadingZeroes :: String -> String 88dropLeadingZeroes s = 89 let x = dropWhile (=='0') s 90 in if null x then "0" else x 91 92-- foo/bar/baz -> [foo/bar/baz,bar/baz,baz] 93pathParts :: FilePath -> [FilePath] 94pathParts p = p : let d = dropDrive p 95 in if null d || d == p 96 then f d 97 else d : f d 98 where 99 f [] = [] 100 f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs 101 f (x:xs) = 102 if isPathSeparator x 103 then xs : f xs 104 else f xs 105 106-- Significantly speedier than System.Directory.doesDirectoryExist. 107doesDirectoryExist :: FilePath -> IO Bool 108#if mingw32_HOST_OS 109-- This one allocates more memory since it has to do a UTF-16 conversion, but 110-- that can't really be helped: the below version is locale-dependent. 111doesDirectoryExist = flip withTString $ \s -> do 112 a <- c_GetFileAttributes s 113 return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0) 114#else 115doesDirectoryExist s = 116 allocaBytes sizeof_stat $ \p -> 117 withCString 118 (if isDrive s 119 then addTrailingPathSeparator s 120 else dropTrailingPathSeparator s) 121 $ \c -> do 122 st <- lstat c p 123 if st == 0 124 then fmap s_isdir (st_mode p) 125 else return False 126#endif 127 128getRecursiveContents :: FilePath -> IO (DList FilePath) 129getRecursiveContents dir = 130 flip catchIO (\_ -> return $ DL.singleton dir) $ do 131 132 raw <- getDirectoryContents dir 133 134 let entries = map (dir </>) (raw \\ [".",".."]) 135 (dirs,files) <- partitionM doesDirectoryExist entries 136 137 subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs 138 139 return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs) 140 141partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) 142partitionM p_ = foldM (f p_) ([],[]) 143 where 144 f p (ts,fs) x = p x >>= \b -> 145 if b 146 then return (x:ts, fs) 147 else return (ts, x:fs) 148 149partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a) 150partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty) 151 where 152 f p x (ts,fs) = 153 if p x 154 then (DL.cons x ts, fs) 155 else (ts, DL.cons x fs) 156 157tailDL :: DList a -> DList a 158#if MIN_VERSION_dlist(1,0,0) 159tailDL = DL.fromList . DL.tail 160#else 161tailDL = DL.tail 162#endif 163 164nubOrd :: Ord a => [a] -> [a] 165nubOrd = go Set.empty 166 where 167 go _ [] = [] 168 go set (x:xs) = 169 if Set.member x set 170 then go set xs 171 else x : go (Set.insert x set) xs 172 173catchIO :: IO a -> (E.IOException -> IO a) -> IO a 174catchIO = E.catch 175