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