module System.FilePath.Glob.Directory (globDir) where
import Control.Monad (forM)
import qualified Data.DList as DL
import Data.DList (DList)
import Data.List ((\\))
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, partitionDL)
data TypedPattern
= Any Pattern
| Dir Pattern
| AnyDir Pattern
deriving Show
globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath])
globDir [] dir = do
c <- getRecursiveContents dir
return ([], DL.toList c)
globDir pats dir = do
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 ( map DL.toList matches
, nubOrd allOthers \\ allMatches
)
globDir' :: [TypedPattern] -> FilePath -> IO (DList FilePath, DList FilePath)
globDir' [] dir = didn'tMatch dir True
globDir' pats dir = do
raw <- getDirectoryContents dir
let entries = raw \\ [".",".."]
results <- forM entries $ \e -> matchTypedAndGo pats e (dir </> e)
let (matches, others) = unzip results
return (DL.concat matches, DL.concat others)
matchTypedAndGo :: [TypedPattern]
-> FilePath -> FilePath
-> IO (DList FilePath, DList FilePath)
matchTypedAndGo [Any p] path absPath =
if match p path
then return (DL.singleton absPath, DL.empty)
else doesDirectoryExist absPath >>= didn'tMatch absPath
matchTypedAndGo (Dir p:ps) path absPath = do
isDir <- doesDirectoryExist absPath
if isDir && match p path
then globDir' ps absPath
else didn'tMatch absPath isDir
matchTypedAndGo (AnyDir p:ps) path absPath = do
isDir <- doesDirectoryExist absPath
let m = match (unseparate ps)
case null (unPattern p) || match p path of
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 (DList FilePath, DList FilePath)
didn'tMatch absPath isDir = (fmap $ (,) DL.empty) $
if isDir
then getRecursiveContents absPath
else return$ DL.singleton absPath
separate :: Pattern -> [TypedPattern]
separate = go [] . unPattern
where
go [] [] = []
go gr [] = [Any $ f gr]
go gr (ExtSeparator:PathSeparator:ps) = go gr ps
go gr ( PathSeparator:ps) = ( Dir $ f gr) : go [] ps
go gr ( AnyDirectory:ps) = (AnyDir $ f gr) : go [] ps
go gr ( p:ps) = go (p:gr) ps
f = Pattern . reverse
unseparate :: [TypedPattern] -> Pattern
unseparate = Pattern . foldr f []
where
f (AnyDir p) ts = unPattern p ++ AnyDirectory : ts
f ( Dir p) ts = unPattern p ++ PathSeparator : ts
f (Any p) ts = unPattern p ++ ts