equal-files-0.0.3: src/Main.hs

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