diff --git a/Glob.cabal b/Glob.cabal --- a/Glob.cabal +++ b/Glob.cabal @@ -1,7 +1,7 @@ Cabal-Version: >= 1.2 Name: Glob -Version: 0.1 +Version: 0.2 Homepage: http://iki.fi/matti.niemenmaa/glob/ Synopsis: Globbing library Category: System @@ -24,6 +24,7 @@ Build-Depends: base >= 3 && < 5 , containers == 0.* , directory == 1.* + , dlist == 0.* , filepath == 1.* , mtl == 1.* diff --git a/System/FilePath/Glob/Directory.hs b/System/FilePath/Glob/Directory.hs --- a/System/FilePath/Glob/Directory.hs +++ b/System/FilePath/Glob/Directory.hs @@ -3,13 +3,16 @@ module System.FilePath.Glob.Directory (globDir) where import Control.Monad (forM) +import qualified Data.DList as DL +import Data.DList (DList) import Data.List ((\\), partition) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (()) import System.FilePath.Glob.Base import System.FilePath.Glob.Match (match) -import System.FilePath.Glob.Utils (getRecursiveContents, nubOrd, pathParts) +import System.FilePath.Glob.Utils + (getRecursiveContents, nubOrd, pathParts, partitionDL) -- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory data TypedPattern @@ -42,10 +45,15 @@ results <- mapM (\p -> globDir' (separate p) dir) pats let (matches, others) = unzip results + allMatches = DL.toList . DL.concat $ matches + allOthers = DL.toList . DL.concat $ others - return (matches, nubOrd (concat others) \\ concat matches) + return ( map DL.toList matches + , nubOrd allOthers \\ allMatches + ) -globDir' :: [TypedPattern] -> FilePath -> IO ([FilePath], [FilePath]) +globDir' :: [TypedPattern] -> FilePath -> IO (DList FilePath, DList FilePath) +globDir' [] _ = return (DL.empty, DL.empty) globDir' pats dir = do raw <- getDirectoryContents dir @@ -55,18 +63,16 @@ let (matches, others) = unzip results - return (concat matches, concat others) + return (DL.concat matches, DL.concat others) matchTypedAndGo :: [TypedPattern] -> FilePath -> FilePath - -> IO ([FilePath], [FilePath]) - -matchTypedAndGo [] _ _ = return ([], []) + -> IO (DList FilePath, DList FilePath) -- (Any p) is always the last element matchTypedAndGo [Any p] path absPath = if match p path - then return ([absPath], []) + then return (DL.singleton absPath, DL.empty) else doesDirectoryExist absPath >>= didn'tMatch absPath matchTypedAndGo (Dir p:ps) path absPath = do @@ -77,21 +83,21 @@ matchTypedAndGo (AnyDir p:ps) path absPath = do isDir <- doesDirectoryExist absPath - let pat = unseparate ps + let m = match (unseparate ps) case null (unPattern p) || match p path of - True | isDir -> fmap (partition (any (match pat) . pathParts)) - (getRecursiveContents absPath) - True | match pat path -> return ([absPath], []) - _ -> didn'tMatch absPath isDir + True | isDir -> fmap (partitionDL (any m . pathParts)) + (getRecursiveContents absPath) + True | m path -> return (DL.singleton absPath, DL.empty) + _ -> didn'tMatch absPath isDir matchTypedAndGo _ _ _ = error "Glob.matchTypedAndGo :: internal error" -didn'tMatch :: FilePath -> Bool -> IO ([FilePath], [FilePath]) -didn'tMatch absPath isDir = (fmap $ (,) []) $ +didn'tMatch :: FilePath -> Bool -> IO (DList FilePath, DList FilePath) +didn'tMatch absPath isDir = (fmap $ (,) DL.empty) $ if isDir then getRecursiveContents absPath - else return [absPath] + else return$ DL.singleton absPath separate :: Pattern -> [TypedPattern] separate = go [] . unPattern diff --git a/System/FilePath/Glob/Utils.hs b/System/FilePath/Glob/Utils.hs --- a/System/FilePath/Glob/Utils.hs +++ b/System/FilePath/Glob/Utils.hs @@ -1,11 +1,23 @@ -- File created: 2008-10-10 13:40:35 -module System.FilePath.Glob.Utils where +module System.FilePath.Glob.Utils + ( isLeft, fromLeft + , increasingSeq + , addToRange, inRange, overlap + , dropLeadingZeroes + , pathParts + , nubOrd + , partitionDL + , getRecursiveContents + ) where -import Data.List ((\\), tails) +import Control.Monad (foldM) +import Data.List ((\\)) +import qualified Data.DList as DL +import Data.DList (DList) import qualified Data.Set as Set import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath ((), joinPath, splitPath) +import System.FilePath ((), isPathSeparator, dropDrive) import System.IO.Unsafe (unsafeInterleaveIO) inRange :: Ord a => (a,a) -> a -> Bool @@ -62,33 +74,47 @@ let x = dropWhile (=='0') s in if null x then "0" else x +-- foo/bar/baz -> [foo/bar/baz,bar/baz,baz] pathParts :: FilePath -> [FilePath] -pathParts = map joinPath . tails . splitPath +pathParts p = p : let d = dropDrive p + in if null d || d == p + then f d + else d : f d + where + f [] = [] + f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs + f (x:xs) = + if isPathSeparator x + then xs : f xs + else f xs -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents dir = flip catch (const $ return []) $ do +getRecursiveContents :: FilePath -> IO (DList FilePath) +getRecursiveContents dir = do raw <- getDirectoryContents dir - let entries = raw \\ [".",".."] - absEntries = - if dir == "." - then entries - else map (dir ) entries + let entries = map (dir ) (raw \\ [".",".."]) - (dirs,files) <- partitionM doesDirectoryExist absEntries + (dirs,files) <- partitionM doesDirectoryExist entries subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs - return$ dir : files ++ concat subs + return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs) partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) -partitionM _ [] = return ([],[]) -partitionM p (x:xs) = do - ~(ts,fs) <- partitionM p xs - b <- p x - return $ if b - then (x:ts, fs) - else (ts, x:fs) +partitionM p_ = foldM (f p_) ([],[]) + where + f p (ts,fs) x = p x >>= \b -> + if b + then return (x:ts, fs) + else return (ts, x:fs) + +partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a) +partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty) + where + f p x (ts,fs) = + if p x + then (DL.cons x ts, fs) + else (ts, DL.cons x fs) nubOrd :: Ord a => [a] -> [a] nubOrd = go Set.empty