diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -4,16 +4,20 @@ module Main where +import Control.Applicative import Control.Concurrent.ParallelIO import Control.DeepSeq import Control.Exception import Control.Lens -import Control.Monad hiding (sequence) -import qualified Data.Text.Encoding as E +import Control.Monad +import Data.DList (DList) +import qualified Data.DList as DL import Data.Function import qualified Data.List as L import Data.Monoid import Data.Text as T hiding (filter, map, chunksOf) +import qualified Data.Text.Encoding as E +import Debug.Trace import Filesystem (listDirectory, isFile) import Filesystem.Path.CurrentOS import GHC.Conc @@ -25,12 +29,11 @@ import Text.Printf import Text.Regex.Posix import Unsafe.Coerce -import Debug.Trace default (Integer, Text) version :: String -version = "2.0.3" +version = "2.0.4" copyright :: String copyright = "2012" @@ -43,9 +46,9 @@ , annex :: Bool , apparent :: Bool , exclude :: String - , minSize :: Integer - , minCount :: Integer - , blockSize :: Integer + , minSize :: Int + , minCount :: Int + , blockSize :: Int , smalls :: Bool -- , dirsOnly :: Bool , depth :: Int @@ -81,20 +84,25 @@ program "sizes" &= help "Calculate amount of disk used by the given directories" -data EntryInfo = EntryInfo { _entryPath :: !FilePath - , _entryCount :: !Integer - , _entryActualSize :: !Integer - , _entryAllocSize :: !Integer - , _entryIsDir :: !Bool } +data EntryInfo = EntryInfo { _entryPath :: FilePath + , _entryCount :: Int + , _entryAllocSize :: Int + , _entryIsDir :: Bool } deriving Show makeLenses ''EntryInfo +newEntry :: FilePath -> Bool -> EntryInfo +newEntry p = EntryInfo p 0 0 + +instance Monoid EntryInfo where + mempty = newEntry "" False + x `mappend` y = seq x $ seq y $ + entryCount +~ y^.entryCount $ + entryAllocSize +~ y^.entryAllocSize $ x + instance NFData EntryInfo where rnf a = a `seq` () - -newEntry :: FilePath -> Bool -> EntryInfo -newEntry p = EntryInfo p 0 0 0 main :: IO () main = do @@ -111,32 +119,35 @@ reportSizes opts $ map (fromText . pack) directories stopGlobalPool +reportEntryP :: SizesOpts -> EntryInfo -> Bool +reportEntryP opts entry = smalls opts + || entry^.entryAllocSize >= minSize' + || entry^.entryCount >= minCount' + where + minSize' = (if minSize opts == 0 then 10 else minSize opts) * 1024^2 + minCount' = if minCount opts == 0 then 100 else minCount opts + reportSizes :: SizesOpts -> [FilePath] -> IO () reportSizes opts xs = do entryInfos <- parallel $ map reportSizesForDir xs - let infos = map fst entryInfos ++ mconcat (map snd entryInfos) - sorted = L.sortBy ((compare `on`) $ if byCount opts - then (^. entryCount) - else (^. entryAllocSize)) infos - forM_ sorted $ \entry -> - when ( smalls opts - || entry^.entryAllocSize >= minSize' - || entry^.entryCount >= minCount') - $ reportEntry entry + let infos = map fst entryInfos ++ + DL.toList (DL.concat (map snd entryInfos)) + sorted = L.sortBy ((compare `on`) $ + if byCount opts + then (^. entryCount) + else (^. entryAllocSize)) infos + mapM_ reportEntry (filter (reportEntryP opts) sorted) where - reportSizesForDir dir = do - fsStatus <- getFilesystemStatus (E.encodeUtf8 (toTextIgnore dir)) + reportSizesForDir = + -- fsStatus <- getFilesystemStatus (E.encodeUtf8 (toTextIgnore dir)) let fsBlkSize = statBlockSize -- filesystemBlockSize fsStatus opts' = if blockSize opts == 0 then opts { blockSize = fromIntegral fsBlkSize } else opts - gatherSizesW opts' 0 dir - - minSize' = (if minSize opts == 0 then 10 else minSize opts) * 1024^2 - minCount' = (if minCount opts == 0 then 100 else minCount opts) + in gatherSizesW opts' 0 -humanReadable :: Integer -> String +humanReadable :: Int -> String humanReadable x | x < 1024 = printf "%db" x | x < 1024^2 = printf "%.0fK" (fromIntegral x / (1024 :: Double)) @@ -149,7 +160,7 @@ reportEntry :: EntryInfo -> IO () reportEntry entry = - let path = unpack . toTextIgnore $ entry^.entryPath + let path = unpack (toTextIgnore (entry^.entryPath)) in printf (unpack "%10s %10d %s%s\n") (humanReadable (entry^.entryAllocSize)) (entry^.entryCount) path @@ -157,57 +168,45 @@ then "/" else "") toTextIgnore :: FilePath -> Text -toTextIgnore p = case toText p of Left _ -> ""; Right x -> x +toTextIgnore = either id id . toText -gatherSizesW :: SizesOpts -> Int -> FilePath -> IO (EntryInfo, [EntryInfo]) +returnEmpty :: FilePath -> IO (EntryInfo, DList EntryInfo) +returnEmpty path = return (newEntry path False, DL.empty) + +gatherSizesW :: SizesOpts -> Int -> FilePath -> IO (EntryInfo, DList EntryInfo) gatherSizesW opts d p = catch (gatherSizes opts d p) - (\e -> do - print (e :: IOException) - return (newEntry p False, [])) - -gatherSizes :: SizesOpts -> Int -> FilePath -> IO (EntryInfo, [EntryInfo]) -gatherSizes opts curDepth path = do - status <- if curDepth == 0 - then getFileStatus path' - else getSymbolicLinkStatus path' - gatherSizes' status + (\e -> print (e :: IOException) >> returnEmpty p) +{-# INLINE gatherSizesW #-} +gatherSizes :: SizesOpts -> Int -> FilePath -> IO (EntryInfo, DList EntryInfo) +gatherSizes opts curDepth path = + gatherSizes' =<< if curDepth == 0 + then getFileStatus path' + else getSymbolicLinkStatus path' where - path' = unpack $ toTextIgnore path - - annexRe = unpack "\\.git/annex/" + path' = unpack (toTextIgnore path) + annexRe = unpack "\\.git/annex/" + minSize' = (if minSize opts == 0 then 10 else minSize opts) * 1024^2 gatherSizes' status - | (exclude opts) /= "" && path' =~ exclude opts = returnEmpty - - | isDirectory status = do - files <- listDirectory path - entries <- let func = gatherSizesW opts (curDepth + 1) . collapse - in if curDepth == 0 - then parallel $ map func files - else mapM func files - - let firsts = map fst entries + | not (L.null (exclude opts)) && path' =~ exclude opts = returnEmpty path - return $!! ( L.foldl' (\current entry -> - entryCount +~ entry^.entryCount $ - entryActualSize +~ entry^.entryActualSize $ - entryAllocSize +~ entry^.entryAllocSize $ current) - (newEntry path True) - firsts - , if curDepth <= depth opts - then firsts ++ L.concatMap snd entries - else [] ) + | isDirectory status = + listDirectory path + >>= mapAndUnzipM (gatherSizesW opts (curDepth + 1) . collapse) + >>= \(xs, ys) -> + let x = mconcat (newEntry path True : xs) + in return (x, if curDepth < depth opts + then DL.append (DL.fromList xs) (mconcat ys) + else DL.empty) - | ( isRegularFile status - && not (annex opts && path' =~ annexRe)) + | (isRegularFile status && not (annex opts && path' =~ annexRe)) || (annex opts && isSymbolicLink status) = catch (getFileSize status) - (\e -> do print (e :: IOException) - returnEmpty) + (\e -> print (e :: IOException) >> returnEmpty path) - | otherwise = returnEmpty + | otherwise = returnEmpty path -- If status is for a symbolic link, it must be a Git-annex'd file getFileSize status = do @@ -217,30 +216,28 @@ destPath <- readSymbolicLink path' if destPath =~ annexRe then do - let destFilePath = fromText (T.pack destPath) - destPath' = if relative destFilePath - then (T.unpack . toTextIgnore $ - parent path destFilePath) - else destPath - destFilePath' = fromText (T.pack destPath') - exists <- isFile destFilePath' - if exists - then getFileStatus destPath' - else return status + let destFilePath = fromText (T.pack destPath) + destPath' = if relative destFilePath + then T.unpack . toTextIgnore $ + parent path destFilePath + else destPath + destFilePath' = fromText (T.pack destPath') + exists <- isFile destFilePath' + if exists + then getFileStatus destPath' + else return status else return status else return status - let fsize = fromIntegral $ fileSize status' - blksize = fromIntegral $ - fileBlockSize (unsafeCoerce status') - - return ( entryCount .~ 1 - $ entryActualSize .~ fsize - $ entryAllocSize .~ (if apparent opts - then fsize - else blksize * blockSize opts) - $ newEntry path False, []) + let fsize = fileSize status' + blksize = fileBlockSize (unsafeCoerce status') + allocSize = if apparent opts + then fromIntegral fsize + else fromIntegral blksize * blockSize opts - returnEmpty = return (newEntry path False, []) + return (EntryInfo { _entryPath = path + , _entryCount = 1 + , _entryAllocSize = allocSize + , _entryIsDir = False }, DL.empty) -- Main.hs (sizes) ends here diff --git a/sizes.cabal b/sizes.cabal --- a/sizes.cabal +++ b/sizes.cabal @@ -1,6 +1,6 @@ Name: sizes -Version: 2.0.3 +Version: 2.0.4 Synopsis: Recursively show space (size and i-nodes) used in subdirectories Description: Recursively show space (size and i-nodes) used in subdirectories @@ -22,7 +22,7 @@ Include-dirs: . Includes: HsStat.h c-sources: HsStat.c - Ghc-options: -threaded + ghc-options: -threaded -with-rtsopts=-K16M Build-depends: base >= 4 && < 5 , bytestring @@ -33,6 +33,7 @@ , regex-posix >= 0.95 , system-fileio >= 0.3.9 , system-filepath >= 0.4.7 + , dlist >= 0.5 , text , unix