equal-files 0.0.2.1 → 0.0.3
raw patch · 3 files changed
+164/−26 lines, 3 filesdep +FileManipdep +explicit-exceptiondep +mtldep ~base
Dependencies added: FileManip, explicit-exception, mtl
Dependency ranges changed: base
Files
- equal-files.cabal +15/−13
- src/EqualFiles.hs +53/−13
- src/Main.hs +96/−0
equal-files.cabal view
@@ -1,5 +1,5 @@ Name: equal-files-Version: 0.0.2.1+Version: 0.0.3 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -23,11 +23,18 @@ . > find my_dir -type f -printf "'%p'\n" | xargs equal-files .+ or+ .+ > equal_files -r my_dir+ . The program reads all input files simultaneously, driven by sorting and grouping of their content. However be prepared that due to the simultaneous access you may exceed the admissible number of opened files.+ Thus you may prefer to run it like .+ > equal_files -r -p 512 my_dir+ . The program can be used as a nice example of a declarative yet efficient implementation of a non-trivial algorithm, that is enabled by lazy evaluation.@@ -36,20 +43,15 @@ Cabal-Version: >=1.2 Build-Type: Simple -Flag splitBase- description: Choose the new smaller, split-up base package.- Executable equal-files Build-Depends:- bytestring >= 0.9 && <0.10-- If flag(splitBase)- Build-Depends:- base >= 3- Else- Build-Depends:- base >= 1.0 && < 2+ FileManip >= 0.3.2 && <0.4,+ explicit-exception >= 0.0.2 && < 0.1,+ mtl >= 1.1 && < 1.2,+ bytestring >= 0.9 && <0.10,+ base >= 3 GHC-Options: -Wall Hs-source-dirs: src- Main-Is: EqualFiles.hs+ Other-Modules: EqualFiles+ Main-Is: Main.hs
src/EqualFiles.hs view
@@ -1,27 +1,67 @@-module Main where+module EqualFiles where -import System.Environment (getArgs, )-import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import System.IO (openBinaryFile, hClose, IOMode(ReadMode), )+import Control.Exception (bracket, evaluate, )+ import Data.List (groupBy, sort, )+import Data.Function (on, ) +equating :: Eq a => (b -> a) -> b -> b -> Bool+equating = on (==)+ groupEqualElems :: (Ord key, Ord elem) => [(elem, key)] -> [[key]] groupEqualElems xs =- map (map snd) (groupBy (\x y -> fst x == fst y) (sort xs))+ map (map snd) (groupBy (equating fst) (sort xs)) {- | Only return sub-lists with more than one element. -} clusterEqualElems :: (Ord key, Ord elem) => [(elem, key)] -> [[key]] clusterEqualElems xs = filter (not . null . tail) (groupEqualElems xs) -clusterEqualFiles :: [FilePath] -> IO [[FilePath]]-clusterEqualFiles fileNames =- do files <- mapM B.readFile fileNames+{- |+This version does not close the files,+since for the most files 'readFile' does not reach the end of the file+and thus leaves the files open.+-}+clusterLeaveOpen :: [FilePath] -> IO [[FilePath]]+clusterLeaveOpen fileNames =+ do files <- mapM BL.readFile fileNames return (clusterEqualElems (zip files fileNames)) --- output results in a quoted way that might be accessible to further shell scripts-main :: IO ()-main =- mapM_ (putStrLn . unwords . map show) =<<- clusterEqualFiles =<<- getArgs+cluster :: [FilePath] -> IO [[FilePath]]+cluster fileNames =+ do (handles, files) <-+ fmap unzip $+ mapM+ (\fn ->+ do h <- openBinaryFile fn ReadMode+ fmap ((,) h) $ BL.hGetContents h)+ fileNames+ clusters <-+ mapM (mapM evaluate) $+ clusterEqualElems $ zip files fileNames+ mapM_ hClose handles+ return clusters+++readPrefix :: Int -> FilePath -> IO B.ByteString+readPrefix size fileName =+ bracket+ (openBinaryFile fileName ReadMode)+ hClose+ (flip B.hGet size)++clusterWithPreSort :: Int -> [FilePath] -> IO [[FilePath]]+clusterWithPreSort size fileNames =+ do {- The file prefixes are read strictly+ and thus there is only one file open at a time. -}+ files <- mapM (readPrefix size) fileNames+ {- The files are preclustered according to their prefixes+ and then the preclusters are finally clustered. -}+-- fmap (const []) $ mapM_ (putStrLn . unwords . map show) $+ fmap concat $ mapM cluster $+ clusterEqualElems $ zip files fileNames
+ src/Main.hs view
@@ -0,0 +1,96 @@+module Main where++import qualified EqualFiles++import qualified System.FilePath.Find as FindFile+import System.FilePath.Find ((==?), )++import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )+import System.Environment (getArgs, getProgName, )+import System.Exit (exitWith, ExitCode(..), )+import System.IO.Error (isFullError, )+import Control.Exception (try, ioErrors, )++import Control.Monad (liftM, when, )+import Control.Monad.Trans (lift, )++import qualified Control.Monad.Exception.Synchronous as Exc+++parseCard :: String -> Exc.Exceptional String Int+parseCard str =+ case reads str of+ [(n,"")] ->+ if n>=0+ then return n+ else Exc.throw $ "negative number: " ++ str+ _ -> Exc.throw $ "could not parse cardinal " ++ show str+++elaborateOnExhaustedHandles :: IO a -> Exc.ExceptionalT String IO a+elaborateOnExhaustedHandles action =+ Exc.catchT+ (Exc.fromEitherT $ try $ action)+ (\e ->+ (case ioErrors e of+ Just ioe ->+ when (isFullError ioe)+ (Exc.throwT $ unlines $+ show e :+ "--presort option may help against too many open files." :+ [])+ _ -> return ()) >>+ Exc.throwT (show e))+++data Flags =+ Flags {+ optHelp :: Bool,+ optRecursive :: Bool,+ optPreSort :: Int+ }++options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]+options =+ Option ['h'] ["help"] (NoArg (\flags -> return $ flags{optHelp = True})) "show options" :+ Option ['r'] ["recursive"] (NoArg (\flags -> return $ flags{optRecursive = True})) "descent recursively into directories" :+ Option ['p'] ["presort" ]+ (ReqArg (\str flags -> fmap (\n -> flags{optPreSort = n}) $ Exc.mapException ("presort option:\n"++) $ parseCard str) "N")+ "Sort all files according to their first N bytes in a first go.\nThis reduces the number of simultaneously open files.\nThe suggested size value is 512." :+ []+++-- output results in a quoted way that might be accessible to further shell scripts+main :: IO ()+main =+ Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do+ argv <- lift getArgs+ let (opts, filesAndDirs, errors) = getOpt RequireOrder options argv+ when (not (null errors)) $ Exc.throwT $ concat $ errors+ flags <-+ Exc.ExceptionalT $ return $+ foldr (flip (>>=))+ (return $+ Flags {optHelp = False,+ optRecursive = False,+ optPreSort = 0})+ opts+ when (optHelp flags)+ (lift $+ getProgName >>= \programName ->+ putStrLn+ (usageInfo ("Usage: " ++ programName ++ " [OPTIONS] FILES-AND-DIRECTORIES ...") options) >>+ exitWith ExitSuccess)++ files <-+ if optRecursive flags+ then lift $ liftM concat $+ mapM (FindFile.find FindFile.always (FindFile.fileType ==? FindFile.RegularFile)) filesAndDirs+ else return filesAndDirs++ elaborateOnExhaustedHandles $+ mapM_ (putStrLn . unwords . map show) =<<+ let prefixSize = optPreSort flags+ in if prefixSize>0+ then EqualFiles.clusterWithPreSort prefixSize files+ else EqualFiles.clusterLeaveOpen files