filemanip-0.3.6.3/0000755000000000000000000000000012457562753012033 5ustar0000000000000000filemanip-0.3.6.3/filemanip.cabal0000644000000000000000000000230712457562753014765 0ustar0000000000000000Name: filemanip Version: 0.3.6.3 License: BSD3 License-File: LICENSE Author: Bryan O'Sullivan Maintainer: Bryan O'Sullivan Homepage: https://github.com/bos/filemanip Bug-reports: https://github.com/bos/filemanip/issues 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 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 source-repository head type: git location: git://github.com/bos/filemanip.git source-repository head type: mercurial location: https://bitbucket.org/bos/filemanip filemanip-0.3.6.3/LICENSE0000644000000000000000000000271012457562753013040 0ustar0000000000000000Copyright (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. filemanip-0.3.6.3/README.markdown0000644000000000000000000000121112457562753014527 0ustar0000000000000000# filemanip: expressive file manipulation This package provides functions and combinators for searching, matching, and manipulating files. # Get involved! Please report bugs via the [github issue tracker](https://github.com/bos/filemanip/issues). Master [git repository](http://github.com/bos/filemanip): * `git clone git://github.com/bos/filemanip.git` There's also a [Mercurial mirror](http://bitbucket.org/bos/filemanip): * `hg clone https://bitbucket.org/bos/filemanip` (You can create and contribute changes using either Mercurial or git.) # Authors This library is written and maintained by Bryan O'Sullivan, . filemanip-0.3.6.3/Setup.lhs0000644000000000000000000000011412457562753013637 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain filemanip-0.3.6.3/System/0000755000000000000000000000000012457562753013317 5ustar0000000000000000filemanip-0.3.6.3/System/FilePath/0000755000000000000000000000000012457562753015013 5ustar0000000000000000filemanip-0.3.6.3/System/FilePath/Find.hs0000644000000000000000000004121412457562753016231 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module: System.FilePath.Find -- Copyright: Bryan O'Sullivan -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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 'True' 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 for canonical path and name , canonicalPath , canonicalName -- ** Combinators that operate on symbolic links , readLink , followStatus -- ** Common binary operators, lifted as combinators -- $binaryOperators , (~~?) , (/~?) , (==?) , (/=?) , (>?) , (=?) , (<=?) , (.&.?) -- ** Combinators for gluing clauses together , (&&?) , (||?) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative) #endif import qualified Control.Exception as E import Control.Exception (IOException, handle) import Control.Monad (foldM, forM, liftM, liftM2) import Control.Monad.State (State, evalState, get) import Data.Bits (Bits, (.&.)) import Data.List (sort) import System.Directory (getDirectoryContents, canonicalizePath) 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 -- | 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, Applicative, 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) -- | Return the current 'FileInfo'. fileInfo :: FindClause FileInfo fileInfo = FC $ get -- | 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 <- E.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 -- | Return the canonical path of the file being visited. -- -- See `canonicalizePath` for details of what canonical path means. canonicalPath :: FindClause FilePath canonicalPath = (unsafePerformIO . canonicalizePath) `liftM` filePath -- | Return the canonical name of the file (canonical path with the -- directory part removed). canonicalName :: FindClause FilePath canonicalName = takeFileName `liftM` canonicalPath -- | 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 >? ( FindClause a -> a -> FindClause Bool (=?) :: 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 ||? filemanip-0.3.6.3/System/FilePath/Glob.hs0000644000000000000000000000504112457562753016232 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module: System.FilePath.Glob -- Copyright: Bryan O'Sullivan -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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 filemanip-0.3.6.3/System/FilePath/GlobPattern.hs0000644000000000000000000001511512457562753017573 0ustar0000000000000000-- | -- Module: System.FilePath.GlobPattern -- Copyright: Bryan O'Sullivan -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- Stability: unstable -- Portability: everywhere module System.FilePath.GlobPattern ( -- * Glob patterns -- $syntax GlobPattern -- * Matching functions , (~~) , (/~) ) where import Control.Arrow (second) import Control.Monad (msum) 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) ("",ss) -> MatchGroup ss : simplifyTerms 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 = msum (map matchGroup g) where matchGroup g = matchTerms (MatchLiteral g : ts) cs 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 . ) . (~~) filemanip-0.3.6.3/System/FilePath/Manip.hs0000644000000000000000000000753512457562753016425 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-} -- | -- Module: System.FilePath.Manip -- Copyright: Bryan O'Sullivan -- License: BSD3 -- Maintainer: Bryan O'Sullivan -- 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.PosixCompat.Files (fileMode, getFileStatus, rename, setFileMode) import System.PosixCompat.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