filemanip (empty) → 0.3.5.0
raw patch · 8 files changed
+998/−0 lines, 8 filesdep +basedep +bytestringdep +directorysetup-changed
Dependencies added: base, bytestring, directory, filepath, mtl, unix, unix-compat
Files
- LICENSE +27/−0
- README.markdown +26/−0
- Setup.lhs +3/−0
- System/FilePath/Find.hs +548/−0
- System/FilePath/Glob.hs +73/−0
- System/FilePath/GlobPattern.hs +178/−0
- System/FilePath/Manip.hs +113/−0
- filemanip.cabal +30/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Bryan O'Sullivan 2007, 2010.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,26 @@+# filemanip: expressive file manipulation++This package provides functions and combinators for searching,+matching, and manipulating files.+++# Get involved!++Please report bugs via the+[bitbucket issue tracker](http://bitbucket.org/bos/attoparsec/filemanip).++Master [Mercurial repository](http://bitbucket.org/bos/filemanip):++* `hg clone http://bitbucket.org/bos/filemanip`++There's also a [git mirror](http://github.com/bos/filemanip):++* `git clone git://github.com/bos/filemanip.git`++(You can create and contribute changes using either Mercurial or git.)+++# Authors++This library is written and maintained by Bryan O'Sullivan,+<bos@serpentine.com>.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ System/FilePath/Find.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: System.FilePath.Find+-- Copyright: Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: unstable+-- Portability: Unix-like systems (requires newtype deriving)+--+-- This module provides functions for traversing a filesystem+-- hierarchy. The 'find' function generates a lazy list of matching+-- files, while 'fold' performs a left fold.+--+-- Both 'find' and 'fold' allow fine control over recursion, using the+-- 'FindClause' type. This type is also used to pre-filter the results+-- returned by 'find'.+--+-- The 'FindClause' type lets you write filtering and recursion+-- control expressions clearly and easily.+--+-- For example, this clause matches C source files.+--+-- @+-- 'extension' '==?' \".c\" '||?' 'extension' '==?' \".h\"+-- @+--+-- Because 'FindClause' is a monad, you can use the usual monad+-- machinery to, for example, lift pure functions into it.+--+-- Here's a clause that will return 'False' for any file whose+-- directory name contains the word @\"temp\"@.+--+-- @+-- (isInfixOf \"temp\") \`liftM\` 'directory'+-- @++module System.FilePath.Find (+ FileInfo(..)+ , FileType(..)+ , FindClause+ , FilterPredicate+ , RecursionPredicate++ -- * Simple entry points+ , find+ , fold++ -- * More expressive entry points+ , findWithHandler+ , foldWithHandler++ -- * Helper functions+ , evalClause+ , statusType+ , liftOp++ -- * Combinators for controlling recursion and filtering behaviour+ , filePath+ , fileStatus+ , depth+ , fileInfo++ , always+ , extension+ , directory+ , fileName++ , fileType++ , contains++ -- ** Combinator versions of 'F.FileStatus' functions from "System.Posix.Files"+ -- $statusFunctions++ , deviceID+ , fileID+ , fileOwner+ , fileGroup+ , fileSize+ , linkCount+ , specialDeviceID+ , fileMode+ , accessTime+ , modificationTime+ , statusChangeTime++ -- *** Convenience combinators for file status+ , filePerms+ , anyPerms++ -- ** Combinators that operate on symbolic links+ , readLink+ , followStatus++ -- ** Common binary operators, lifted as combinators+ -- $binaryOperators+ , (~~?)+ , (/~?)+ , (==?)+ , (/=?)+ , (>?)+ , (<?)+ , (>=?)+ , (<=?)+ , (.&.?)++ -- ** Combinators for gluing clauses together+ , (&&?)+ , (||?)+ ) where++import Control.Exception+import Control.Monad (foldM, forM, liftM, liftM2)+import Control.Monad.State (State(..), evalState)+import Data.Bits (Bits, (.&.))+import Data.List (sort)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)+import System.FilePath.GlobPattern (GlobPattern, (~~), (/~))+import System.IO (hPutStrLn, stderr)+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)+import qualified System.PosixCompat.Files as F+import qualified System.PosixCompat.Types as T+import Prelude hiding (catch)++-- | Information collected during the traversal of a directory.+data FileInfo = FileInfo+ {+ infoPath :: FilePath -- ^ file path+ , infoDepth :: Int -- ^ current recursion depth+ , infoStatus :: F.FileStatus -- ^ status of file+ } deriving (Eq)++instance Eq F.FileStatus where+ a == b = F.deviceID a == F.deviceID b &&+ F.fileID a == F.fileID b++-- | Construct a 'FileInfo' value.++mkFI :: FilePath -> Int -> F.FileStatus -> FileInfo++mkFI = FileInfo++-- | Monadic container for file information, allowing for clean+-- construction of combinators. Wraps the 'State' monad, but doesn't+-- allow 'get' or 'put'.+newtype FindClause a = FC { runFC :: State FileInfo a }+ deriving (Functor, Monad)++-- | Run the given 'FindClause' on the given 'FileInfo' and return its+-- result. This can be useful if you are writing a function to pass+-- to 'fold'.+--+-- Example:+--+-- @+-- myFoldFunc :: a -> 'FileInfo' -> a+-- myFoldFunc a i = let useThisFile = 'evalClause' ('fileName' '==?' \"foo\") i+-- in if useThisFile+-- then fiddleWith a+-- else a+-- @+evalClause :: FindClause a -> FileInfo -> a+evalClause = evalState . runFC++evalFI :: FindClause a+ -> FilePath+ -> Int+ -> F.FileStatus+ -> a+evalFI m p d s = evalClause m (mkFI p d s)++mkFindClause :: (FileInfo -> (a, FileInfo)) -> FindClause a+mkFindClause = FC . State++-- | Return the current 'FileInfo'.+fileInfo :: FindClause FileInfo++fileInfo = mkFindClause $ \st -> (st, st)++-- | Return the name of the file being visited.+filePath :: FindClause FilePath++filePath = infoPath `liftM` fileInfo++-- | Return the current recursion depth.+depth :: FindClause Int++depth = infoDepth `liftM` fileInfo++-- | Return the 'F.FileStatus' for the current file.+fileStatus :: FindClause F.FileStatus++fileStatus = infoStatus `liftM` fileInfo++type FilterPredicate = FindClause Bool+type RecursionPredicate = FindClause Bool++-- | List the files in the given directory, sorted, and without \".\"+-- or \"..\".+getDirContents :: FilePath -> IO [FilePath]++getDirContents dir = (sort . filter goodName) `liftM` getDirectoryContents dir+ where goodName "." = False+ goodName ".." = False+ goodName _ = True++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'. Lazily return a sorted list of all files+-- matching the given 'FilterPredicate'. Any errors that occur are+-- dealt with by the given handler.+findWithHandler ::+ (FilePath -> IOException -> IO [FilePath]) -- ^ error handler+ -> RecursionPredicate -- ^ control recursion into subdirectories+ -> FilterPredicate -- ^ decide whether a file appears in the result+ -> FilePath -- ^ directory to start searching+ -> IO [FilePath] -- ^ files that matched the 'FilterPredicate'++findWithHandler errHandler recurse filt path0 =+ handle (errHandler path0) $ F.getSymbolicLinkStatus path0 >>= visit path0 0+ where visit path depth st =+ if F.isDirectory st && evalFI recurse path depth st+ then unsafeInterleaveIO (traverse path (succ depth) st)+ else filterPath path depth st []+ traverse dir depth dirSt = do+ names <- catch (getDirContents dir) (errHandler dir)+ filteredPaths <- forM names $ \name -> do+ let path = dir </> name+ unsafeInterleaveIO $ handle (errHandler path)+ (F.getSymbolicLinkStatus path >>= visit path depth)+ filterPath dir depth dirSt (concat filteredPaths)+ filterPath path depth st result =+ return $ if evalFI filt path depth st+ then path:result+ else result++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'. Lazily return a sorted list of all files+-- matching the given 'FilterPredicate'. Any errors that occur are+-- ignored, with warnings printed to 'stderr'.+find :: RecursionPredicate -- ^ control recursion into subdirectories+ -> FilterPredicate -- ^ decide whether a file appears in the result+ -> FilePath -- ^ directory to start searching+ -> IO [FilePath] -- ^ files that matched the 'FilterPredicate'++find = findWithHandler warnOnError+ where warnOnError path err =+ hPutStrLn stderr (path ++ ": " ++ show err) >> return []++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'. Fold over all files found. Any errors that+-- occur are dealt with by the given handler. The fold is strict, and+-- run from \"left\" to \"right\", so the folded function should be+-- strict in its left argument to avoid space leaks. If you need a+-- right-to-left fold, use 'foldr' on the result of 'findWithHandler'+-- instead.+foldWithHandler+ :: (FilePath -> a -> IOException -> IO a) -- ^ error handler+ -> RecursionPredicate -- ^ control recursion into subdirectories+ -> (a -> FileInfo -> a) -- ^ function to fold with+ -> a -- ^ seed value for fold+ -> FilePath -- ^ directory to start searching+ -> IO a -- ^ final value after folding++foldWithHandler errHandler recurse f state path =+ handle (errHandler path state) $+ F.getSymbolicLinkStatus path >>= visit state path 0+ where visit state path depth st =+ if F.isDirectory st && evalFI recurse path depth st+ then traverse state path (succ depth) st+ else let state' = f state (mkFI path depth st)+ in state' `seq` return state'+ traverse state dir depth dirSt = handle (errHandler dir state) $+ getDirContents dir >>=+ let state' = f state (mkFI dir depth dirSt)+ in state' `seq` flip foldM state' (\state name ->+ handle (errHandler dir state) $+ let path = dir </> name+ in F.getSymbolicLinkStatus path >>= visit state path depth)++-- | Search a directory recursively, with recursion controlled by a+-- 'RecursionPredicate'. Fold over all files found. Any errors that+-- occur are ignored, with warnings printed to 'stderr'. The fold+-- function is run from \"left\" to \"right\", so it should be strict+-- in its left argument to avoid space leaks. If you need a+-- right-to-left fold, use 'foldr' on the result of 'findWithHandler'+-- instead.+fold :: RecursionPredicate+ -> (a -> FileInfo -> a)+ -> a+ -> FilePath+ -> IO a++fold = foldWithHandler warnOnError+ where warnOnError path a err = + hPutStrLn stderr (path ++ ": " ++ show err) >> return a++-- | Unconditionally return 'True'.+always :: FindClause Bool+always = return True++-- | Return the file name extension.+--+-- Example:+--+-- @+-- 'extension' \"foo\/bar.txt\" => \".txt\"+-- @+extension :: FindClause FilePath+extension = takeExtension `liftM` filePath++-- | Return the file name, without the directory name.+--+-- What this means in practice:+--+-- @+-- 'fileName' \"foo\/bar.txt\" => \"bar.txt\"+-- @+--+-- Example:+--+-- @+-- 'fileName' '==?' \"init.c\"+-- @+fileName :: FindClause FilePath+fileName = takeFileName `liftM` filePath++-- | Return the directory name, without the file name.+--+-- What this means in practice:+--+-- @+-- 'directory' \"foo\/bar.txt\" => \"foo\"+-- @+--+-- Example in a clause:+--+-- @+-- let hasSuffix = 'liftOp' 'isSuffixOf'+-- in directory \`hasSuffix\` \"tests\"+-- @+directory :: FindClause FilePath+directory = takeDirectory `liftM` filePath++-- | Run the given action in the 'IO' monad (using 'unsafePerformIO')+-- if the current file is a symlink. Hide errors by wrapping results+-- in the 'Maybe' monad.+withLink :: (FilePath -> IO a) -> FindClause (Maybe a)++withLink f = do+ path <- filePath+ st <- fileStatus+ return $ if F.isSymbolicLink st+ then unsafePerformIO $ handle (\(_::IOException) -> return Nothing) $+ Just `liftM` f path+ else Nothing++-- | If the current file is a symbolic link, return 'Just' the target+-- of the link, otherwise 'Nothing'.+readLink :: FindClause (Maybe FilePath)++readLink = withLink F.readSymbolicLink++-- | If the current file is a symbolic link, return 'Just' the status+-- of the ultimate endpoint of the link. Otherwise (including in the+-- case of an error), return 'Nothing'.+--+-- Example:+--+-- @+-- 'statusType' \`liftM\` 'followStatus' '==?' 'RegularFile'+-- @+followStatus :: FindClause (Maybe F.FileStatus)++followStatus = withLink F.getFileStatus++data FileType = BlockDevice+ | CharacterDevice+ | NamedPipe+ | RegularFile+ | Directory+ | SymbolicLink+ | Socket+ | Unknown+ deriving (Eq, Ord, Show)++-- | Return the type of file currently being visited.+--+-- Example:+--+-- @+-- 'fileType' '==?' 'RegularFile'+-- @+fileType :: FindClause FileType++fileType = statusType `liftM` fileStatus++-- | Return the type of a file. This is much more useful for case+-- analysis than the usual functions on 'F.FileStatus' values.+statusType :: F.FileStatus -> FileType++statusType st | F.isBlockDevice st = BlockDevice+statusType st | F.isCharacterDevice st = CharacterDevice+statusType st | F.isNamedPipe st = NamedPipe+statusType st | F.isRegularFile st = RegularFile+statusType st | F.isDirectory st = Directory+statusType st | F.isSymbolicLink st = SymbolicLink+statusType st | F.isSocket st = Socket+statusType _ = Unknown++-- $statusFunctions+-- +-- These are simply lifted versions of the 'F.FileStatus' accessor+-- functions in the "System.Posix.Files" module. The definitions all+-- have the following form:+--+-- @+-- 'deviceID' :: 'FindClause' "System.Posix.Types".DeviceID+-- 'deviceID' = "System.Posix.Files".deviceID \`liftM\` 'fileStatus'+-- @++deviceID :: FindClause T.DeviceID+deviceID = F.deviceID `liftM` fileStatus++fileID :: FindClause T.FileID+fileID = F.fileID `liftM` fileStatus++fileOwner :: FindClause T.UserID+fileOwner = F.fileOwner `liftM` fileStatus++fileGroup :: FindClause T.GroupID+fileGroup = F.fileGroup `liftM` fileStatus++fileSize :: FindClause T.FileOffset+fileSize = F.fileSize `liftM` fileStatus++linkCount :: FindClause T.LinkCount+linkCount = F.linkCount `liftM` fileStatus++specialDeviceID :: FindClause T.DeviceID+specialDeviceID = F.specialDeviceID `liftM` fileStatus++fileMode :: FindClause T.FileMode+fileMode = F.fileMode `liftM` fileStatus++-- | Return the permission bits of the 'T.FileMode'.+filePerms :: FindClause T.FileMode+filePerms = (.&. 0777) `liftM` fileMode++-- | Return 'True' if any of the given permission bits is set.+--+-- Example:+--+-- @+-- 'anyPerms' 0444+-- @+anyPerms :: T.FileMode+ -> FindClause Bool+anyPerms m = filePerms >>= \p -> return (p .&. m /= 0)++accessTime :: FindClause T.EpochTime+accessTime = F.accessTime `liftM` fileStatus++modificationTime :: FindClause T.EpochTime+modificationTime = F.modificationTime `liftM` fileStatus++statusChangeTime :: FindClause T.EpochTime+statusChangeTime = F.statusChangeTime `liftM` fileStatus++-- | Return 'True' if the given path exists, relative to the current+-- file. For example, if @\"foo\"@ is being visited, and you call+-- contains @\"bar\"@, this combinator will return 'True' if+-- @\"foo\/bar\"@ exists.+contains :: FilePath -> FindClause Bool+contains p = do+ d <- filePath+ return $ unsafePerformIO $+ handle (\(_::IOException) -> return False) $+ F.getFileStatus (d </> p) >> return True++-- | Lift a binary operator into the 'FindClause' monad, so that it+-- becomes a combinator. The left hand side of the combinator should+-- be a @'FindClause' a@, while the right remains a normal value of+-- type @a@.+liftOp :: Monad m => (a -> b -> c) -> m a -> b -> m c++liftOp f a b = a >>= \a' -> return (f a' b)++-- $binaryOperators+-- +-- These are lifted versions of the most commonly used binary+-- operators. They have the same fixities and associativities as+-- their unlifted counterparts. They are lifted using 'liftOp', like+-- so:+-- +-- @('==?') = 'liftOp' (==)@++-- | Return 'True' if the current file's name matches the given+-- 'GlobPattern'.+(~~?) :: FindClause FilePath -> GlobPattern -> FindClause Bool+(~~?) = liftOp (~~)+infix 4 ~~?++-- | Return 'True' if the current file's name does not match the given+-- 'GlobPattern'.+(/~?) :: FindClause FilePath -> GlobPattern -> FindClause Bool+(/~?) = liftOp (/~)+infix 4 /~?++(==?) :: Eq a => FindClause a -> a -> FindClause Bool+(==?) = liftOp (==)+infix 4 ==?++(/=?) :: Eq a => FindClause a -> a -> FindClause Bool+(/=?) = liftOp (/=)+infix 4 /=?++(>?) :: Ord a => FindClause a -> a -> FindClause Bool+(>?) = liftOp (>)+infix 4 >?++(<?) :: Ord a => FindClause a -> a -> FindClause Bool+(<?) = liftOp (<)+infix 4 <?++(>=?) :: Ord a => FindClause a -> a -> FindClause Bool+(>=?) = liftOp (>=)+infix 4 >=?++(<=?) :: Ord a => FindClause a -> a -> FindClause Bool+(<=?) = liftOp (<=)+infix 4 <=?++-- | This operator is useful to check if bits are set in a+-- 'T.FileMode'.+(.&.?) :: Bits a => FindClause a -> a -> FindClause a+(.&.?) = liftOp (.&.)+infixl 7 .&.?++(&&?) :: FindClause Bool -> FindClause Bool -> FindClause Bool+(&&?) = liftM2 (&&)+infixr 3 &&?++(||?) :: FindClause Bool -> FindClause Bool -> FindClause Bool+(||?) = liftM2 (||)+infixr 2 ||?
+ System/FilePath/Glob.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module: System.FilePath.Glob+-- Copyright: Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: unstable+-- Portability: everywhere++module System.FilePath.Glob (+ namesMatching+ ) where++import Control.Exception+import Control.Monad (forM)+import System.FilePath.GlobPattern ((~~))+import System.Directory (doesDirectoryExist, doesFileExist,+ getCurrentDirectory, getDirectoryContents)+import System.FilePath (dropTrailingPathSeparator, splitFileName, (</>))+import System.IO.Unsafe (unsafeInterleaveIO)++-- | Return a list of names matching a glob pattern. The list is+-- generated lazily.+namesMatching :: String -> IO [FilePath]+namesMatching pat+ | not (isPattern pat) = do+ exists <- doesNameExist pat+ return (if exists then [pat] else [])+ | otherwise = do+ case splitFileName pat of+ ("", baseName) -> do+ curDir <- getCurrentDirectory+ listMatches curDir baseName+ (dirName, baseName) -> do+ dirs <- if isPattern dirName+ then namesMatching (dropTrailingPathSeparator dirName)+ else return [dirName]+ let listDir = if isPattern baseName+ then listMatches+ else listPlain+ pathNames <- forM dirs $ \dir -> do+ baseNames <- listDir dir baseName+ return (map (dir </>) baseNames)+ return (concat pathNames)+ where isPattern = any (`elem` "[*?")++listMatches :: FilePath -> String -> IO [String]+listMatches dirName pat = do+ dirName' <- if null dirName+ then getCurrentDirectory+ else return dirName+ names <- unsafeInterleaveIO (handle (\(_::IOException) -> return []) $+ getDirectoryContents dirName')+ let names' = if isHidden pat+ then filter isHidden names+ else filter (not . isHidden) names+ return (filter (~~ pat) names')+ where isHidden ('.':_) = True+ isHidden _ = False++listPlain :: FilePath -> String -> IO [String]+listPlain dirName baseName = do+ exists <- if null baseName+ then doesDirectoryExist dirName+ else doesNameExist (dirName </> baseName)+ return (if exists then [baseName] else [])++doesNameExist :: FilePath -> IO Bool+doesNameExist name = do+ fileExists <- doesFileExist name+ if fileExists+ then return True+ else doesDirectoryExist name
+ System/FilePath/GlobPattern.hs view
@@ -0,0 +1,178 @@+-- |+-- Module: System.FilePath.GlobPattern+-- Copyright: Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: unstable+-- Portability: everywhere+module System.FilePath.GlobPattern (+ -- * Glob patterns+ -- $syntax+ GlobPattern+ -- * Matching functions+ , (~~)+ , (/~)+ ) where++import Control.Arrow (second)+import Data.Ix (Ix, inRange)+import Data.List (nub)+import Data.Maybe (isJust)+import System.FilePath (pathSeparator)++-- $syntax+--+-- Basic glob pattern syntax is the same as for the Unix shell+-- environment.+-- +-- * @*@ matches everything up to a directory separator or end of+-- string.+--+-- * @[/range/]@ matches any character in /range/.+-- +-- * @[!/range/]@ matches any character /not/ in /range/.+-- +-- There are three extensions to the traditional glob syntax, taken+-- from modern Unix shells.+--+-- * @\\@ escapes a character that might otherwise have special+-- meaning. For a literal @\"\\\"@ character, use @\"\\\\\"@.+-- +-- * @**@ matches everything, including a directory separator.+-- +-- * @(/s1/|/s2/|/.../)@ matches any of the strings /s1/, /s2/, etc.++-- | Glob pattern type.+type GlobPattern = String++spanClass :: Char -> String -> (String, String)++spanClass c = gs []+ where gs _ [] = error "unterminated character class"+ gs acc (d:ds) | d == c = (reverse acc, ds)+ | d == '\\' = case ds of+ (e:es) -> gs (e:'\\':acc) es+ _ -> error "unterminated escape"+ | otherwise = gs (d:acc) ds++data Ix a => SRange a = SRange [a] [(a, a)]+ deriving (Show)++inSRange :: Ix a => a -> SRange a -> Bool++inSRange c (SRange d s) = c `elem` d || any (flip inRange c) s++type CharClass = SRange Char++makeClass :: String -> CharClass++makeClass = makeClass' [] []+ where makeClass' :: [(Char, Char)] -> [Char] -> String -> CharClass+ makeClass' dense sparse [] = SRange sparse dense+ makeClass' dense sparse (a:'-':b:cs) =+ makeClass' ((a,b):dense) sparse cs+ makeClass' dense sparse (c:cs) = makeClass' dense (c:sparse) cs++data MatchTerm = MatchLiteral String+ | MatchAny+ | MatchDir+ | MatchChar+ | MatchClass Bool CharClass+ | MatchGroup [String]+ deriving (Show)++parseGlob :: GlobPattern -> [MatchTerm]+ +parseGlob [] = []+parseGlob ('*':'*':cs) = MatchAny : parseGlob cs+parseGlob ('*':cs) = MatchDir : parseGlob cs+parseGlob ('?':cs) = MatchChar : parseGlob cs+parseGlob ('[':cs) = let (cc, ccs) = spanClass ']' cs+ cls = case cc of+ ('!':ccs') -> MatchClass False $ makeClass ccs'+ _ -> MatchClass True $ makeClass cc+ in cls : parseGlob ccs+parseGlob ('(':cs) = let (gg, ggs) = spanClass ')' cs+ in MatchGroup (breakGroup [] gg) : parseGlob ggs+ where breakGroup :: String -> String -> [String]+ breakGroup acc [] = [reverse acc]+ breakGroup _ ['\\'] = error "group: unterminated escape"+ breakGroup acc ('\\':c:cs') = breakGroup (c:acc) cs'+ breakGroup acc ('|':cs') = reverse acc : breakGroup [] cs'+ breakGroup acc (c:cs') = breakGroup (c:acc) cs'+parseGlob ['\\'] = error "glob: unterminated escape"+parseGlob ('\\':c:cs) = MatchLiteral [c] : parseGlob cs+parseGlob (c:cs) = MatchLiteral [c] : parseGlob cs++simplifyTerms :: [MatchTerm] -> [MatchTerm]+simplifyTerms [] = []+simplifyTerms (MatchLiteral []:as) = simplifyTerms as+simplifyTerms (m@(MatchLiteral a):as) =+ case simplifyTerms as of+ (MatchLiteral b:bs) -> MatchLiteral (a ++ b) : bs+ bs -> m : bs+simplifyTerms (MatchClass True (SRange [] []):as) = simplifyTerms as+simplifyTerms (MatchClass True (SRange a@[_] []):as) =+ simplifyTerms $ MatchLiteral a : as+simplifyTerms (MatchGroup []:as) = simplifyTerms as+simplifyTerms (MatchGroup gs:as) =+ case commonPrefix gs of+ (p,[]) -> simplifyTerms (MatchLiteral p : as)+ (p,ss) -> simplifyTerms (MatchLiteral p : MatchGroup ss : as)+simplifyTerms (a:as) = a:simplifyTerms as++commonPrefix :: [String] -> (String, [String])+commonPrefix = second nub . pfx ""+ where pfx _ [] = ("", [])+ pfx acc ss | any null ss = (reverse acc, ss)+ | otherwise = let hs = map head ss+ h = head hs+ in if all (h==) $ tail hs+ then pfx (h:acc) $ map tail ss+ else (reverse acc, ss)++matchTerms :: [MatchTerm] -> String -> Maybe ()++matchTerms [] [] = return ()+matchTerms [] _ = fail "residual string"+matchTerms (MatchLiteral m:ts) cs = matchLiteral m cs >>= matchTerms ts+ where matchLiteral (a:as) (b:bs) | a == b = matchLiteral as bs+ matchLiteral [] as = return as+ matchLiteral _ _ = fail "not a prefix"+matchTerms (MatchClass k c:ts) cs = matchClass cs >>= matchTerms ts+ where matchClass (b:bs) | (inClass && k) || not (inClass || k) = return bs+ where inClass = b `inSRange` c+ matchClass _ = fail "no match"+matchTerms (MatchGroup g:ts) cs = matchGroup g cs >>= matchTerms ts+ where matchGroup g' as | any null g' = return as+ matchGroup g' (a:as) | a `elem` map head g' =+ matchGroup (map tail g') as+ matchGroup _ _ = fail "not in group"+matchTerms [MatchAny] _ = return ()+matchTerms (MatchAny:ts) cs = matchAny cs >>= matchTerms ts+ where matchAny [] = fail "no match"+ matchAny cs' = case matchTerms ts cs' of+ Nothing -> matchAny (tail cs')+ _ -> return cs+matchTerms [MatchDir] cs | pathSeparator `elem` cs = fail "path separator"+ | otherwise = return ()+matchTerms (MatchDir:ts) cs = matchDir cs >>= matchTerms ts+ where matchDir [] = fail "no match"+ matchDir (c:_) | c == pathSeparator = fail "path separator"+ matchDir cs' = case matchTerms ts cs' of+ Nothing -> matchDir $ tail cs'+ _ -> return cs'+matchTerms (MatchChar:_) [] = fail "end of input"+matchTerms (MatchChar:ts) (_:cs) = matchTerms ts cs++-- | Match a file name against a glob pattern.+(~~) :: FilePath -> GlobPattern -> Bool++name ~~ pat = let terms = simplifyTerms (parseGlob pat)+ in (isJust . matchTerms terms) name++-- | Match a file name against a glob pattern, but return 'True' if+-- the match /fail/s.+(/~) :: FilePath -> GlobPattern -> Bool++(/~) = (not . ) . (~~)
+ System/FilePath/Manip.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-}++-- |+-- Module: System.FilePath.Manip+-- Copyright: Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: unstable+-- Portability: Unix-like systems (requires flexible instances)++module System.FilePath.Manip (+ Streamable(..)+ , renameWith+ , modifyWith+ , modifyWithBackup+ , modifyInPlace+ ) where++import Control.Exception+import Control.Monad (liftM)+import Data.Bits ((.&.))+import System.Directory (removeFile)+import System.IO (Handle, IOMode(..), hClose, openFile)+import System.Posix.Files (fileMode, getFileStatus, rename, setFileMode)+import System.Posix.Temp (mkstemp)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified System.IO as I++-- | Use a renaming function to generate a new name for a file, then+-- rename it.+renameWith :: (FilePath -> FilePath) -- ^ function to rename with+ -> FilePath -- ^ file to rename+ -> IO ()++renameWith f path = rename path (f path)++-- | Type class for string manipulation over files.+class Streamable a where+ -- | Read the entire contents of a 'Handle'.+ readAll :: Handle -> IO a+ -- | Write an entire string to a 'Handle'.+ writeAll :: Handle -> a -> IO ()++instance Streamable B.ByteString where+ readAll = B.hGetContents+ writeAll = B.hPut++instance Streamable L.ByteString where+ readAll = L.hGetContents+ writeAll = L.hPut++instance Streamable String where+ readAll = I.hGetContents+ writeAll = I.hPutStr++-- | Modify a file in place using the given function. This is+-- performed by writing to a temporary file, then renaming it on top of+-- the existing file when done.+modifyInPlace :: Streamable a => (a -> a) -- ^ transformation function+ -> FilePath -- ^ name of file to modify+ -> IO ()++modifyInPlace = modifyWith (flip rename)++-- | Modify a file in place using the given function. The original+-- copy of the file is saved under a new name. This is performed by+-- writing to a temporary file; renaming the original file to its new+-- name; then renaming the temporary file to the original name.+--+-- Example:+--+-- @+-- -- save original file with a \".bak\" extension+-- 'modifyWithBackup' (\<.\> \"bak\")+-- @ +modifyWithBackup :: Streamable a =>+ (FilePath -> FilePath) -- ^ chooses new name for original file+ -> (a -> a) -- ^ transformation function+ -> FilePath -- ^ name of file to modify+ -> IO ()++modifyWithBackup f = modifyWith backup+ where backup path tmpPath = renameWith f path >> rename tmpPath path++-- | Modify a file in place using the given function. The new content+-- is written to a temporary file. Once this is complete, the file+-- manipulation action is called. Its arguments are the names of the+-- original and temporary files.+--+-- Example:+--+-- @+-- 'modifyInPlace' = 'modifyWith' (flip rename)+-- @ +modifyWith :: Streamable a =>+ (FilePath -> FilePath -> IO ()) -- ^ file manipulation action+ -> (a -> a) -- ^ transformation function+ -> FilePath+ -> IO ()++modifyWith after transform path =+ bracket (openFile path ReadMode) hClose $ \ih -> do+ (tmpPath, oh) <- mkstemp (path ++ "XXXXXX")+ let ignore = return ()+ nukeTmp = handle (\(_::IOException) -> ignore) (removeFile tmpPath)+ handle (\(e::IOException) -> nukeTmp >> throw e) $ do+ bracket_ ignore (hClose oh) $+ readAll ih >>= return . transform >>= writeAll oh+ handle (\(_::IOException) -> nukeTmp) $ do+ mode <- fileMode `liftM` getFileStatus path+ setFileMode tmpPath (mode .&. 0777)+ after path tmpPath
+ filemanip.cabal view
@@ -0,0 +1,30 @@+Name: filemanip+Version: 0.3.5.0+License: BSD3+License-File: LICENSE+Author: Bryan O'Sullivan <bos@serpentine.com>+Maintainer: Bryan O'Sullivan+Synopsis: Expressive file and directory manipulation for Haskell.+Category: System+Description: A Haskell library for working with files and directories.+ Includes code for pattern matching, finding files,+ modifying file contents, and more.+Cabal-version: >= 1.6+Build-type: Simple++Extra-Source-Files: README.markdown++Library+ build-depends: base < 5, bytestring, directory, filepath, mtl, unix-compat+ if !os(windows)+ build-depends: unix+ if impl(ghc >= 6.10)+ build-depends:+ base >= 4+ + GHC-Options: -Wall+ Exposed-Modules:+ System.FilePath.Find,+ System.FilePath.Glob,+ System.FilePath.GlobPattern,+ System.FilePath.Manip