diff --git a/app/Main.hs b/app/Main.hs index 580ade8..b4304e0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,12 +1,14 @@ {-# LANGUAGE BlockArguments #-} module Main where +import Prelude hiding ( lookup ) import System.Posix.Directory ( getWorkingDirectory, changeWorkingDirectory ) import System.Directory ( pathIsSymbolicLink , doesFileExist , getFileSize , doesDirectoryExist ) import Data.Functor ( (<&>) ) +import Data.IORef import Control.Monad ( filterM ) import Control.Monad.IO.Class import System.Directory.Extra ( listContents ) @@ -14,10 +16,12 @@ import System.IO.Error import Brick import Brick.Widgets.Edit import Graphics.Vty -import Data.List.Extra +import Data.List.Extra ( sortOn + , (!?)) import qualified Data.Ord import Data.Maybe - +import Data.IOHashMap hiding ( foldr + , (!?) ) listNonSymFiles :: FilePath -> IO [FilePath] listNonSymFiles dir = filterM ((not <$>) . pathIsSymbolicLink) =<< filterM doesFileExist =<< listContents dir @@ -31,19 +35,27 @@ listSym dir = filterM pathIsSymbolicLink =<< listContents dir handlePermissionError :: IOError -> IO Integer handlePermissionError e = if isPermissionError e then pure 0 else ioError e -getSizeSubpaths :: FilePath -> IO [(FilePath, Integer)] -getSizeSubpaths x = do - sub <- listNonSymDirectories x - subby <- mapM - (\y -> (y,) . sum . map snd <$> - getSizeSubpaths y) - sub - syms <- listSym x - local <- listNonSymFiles x >>= - (\y -> mapM - (flip catchIOError handlePermissionError . getFileSize) y <&> - zip y) - pure $ sortOn (Data.Ord.Down . snd) $ local ++ subby ++ zip syms [0..0] +getSizeSubpaths :: FilePath -> IORef (IOHashMap FilePath [(FilePath, Integer)]) -> IO [(FilePath, Integer)] +getSizeSubpaths x i = do + memo <- readIORef i + val <- lookup x memo + case val of + Just b -> pure b + _ -> do + sub <- listNonSymDirectories x + subby <- mapM + (\y -> (y,) . sum . map snd <$> + getSizeSubpaths y i) + sub + syms <- listSym x + local <- listNonSymFiles x >>= + (\y -> mapM + (flip catchIOError handlePermissionError . getFileSize) y <&> + zip y) + let temp = sortOn (Data.Ord.Down . snd) $ local ++ subby ++ zip syms [0..0] + insert x temp memo + writeIORef i memo + pure temp data ScrollDirection where @@ -56,6 +68,7 @@ data AppS = AppS , appCursor :: Int , appFocus :: Maybe FilePath , appSubFiles :: [(FilePath, Integer)] + , appMemo :: IORef (IOHashMap FilePath [(FilePath, Integer)]) } app :: App AppS e () @@ -109,7 +122,7 @@ pathWidget (f, s) = str (show f) <+> padLeft Max (str (unitSize s)) sizeDir :: AppS -> IO AppS sizeDir s = do - subFiles <- getSizeSubpaths $ appCWD s + subFiles <- getSizeSubpaths (appCWD s) (appMemo s) pure $ s { appCursor = 0 @@ -133,11 +146,16 @@ changeDir so | otherwise = pure so where path = fromJust $ appFocus so -overDir :: IO AppS -overDir = do +overDir :: AppS -> IO AppS +overDir s = do changeWorkingDirectory ".." a <- getWorkingDirectory - changeDir $ initialState a + changeDir $ s { + appCWD = a + , appCursor = 0 + , appFocus = pure a + , appSubFiles = [] + } scroll :: ScrollDirection -> AppS -> AppS scroll d s = s { @@ -164,8 +182,8 @@ eventHandler (VtyEvent (EvKey k _)) = do (KChar 'k') -> put $ scroll SUp s KUp -> put $ scroll SUp s - (KChar 'h') -> put =<< liftIO overDir - KLeft -> put =<< liftIO overDir + (KChar 'h') -> put =<< liftIO (overDir s) + KLeft -> put =<< liftIO (overDir s) (KChar ' ') -> put =<< liftIO (changeDir s) KEnter -> put =<< liftIO (changeDir s) @@ -173,21 +191,23 @@ eventHandler (VtyEvent (EvKey k _)) = do KRight -> put =<< liftIO (changeDir s) _ -> continueWithoutRedraw - +eventHandler (VtyEvent (EvResize _ _)) = pure () eventHandler _ = undefined -initialState :: FilePath -> AppS -initialState f = +initialState :: FilePath -> IORef (IOHashMap FilePath [(FilePath, Integer)]) -> AppS +initialState f i = AppS { appCWD = f , appCursor = 0 , appFocus = pure f , appSubFiles = [] + , appMemo = i } main :: IO () main = do a <- getWorkingDirectory - b <- changeDir $ initialState a - _ <- defaultMain app b + b <- newIORef =<< empty + c <- changeDir $ initialState a b + _ <- defaultMain app c return () diff --git a/hcdu.cabal b/hcdu.cabal index c1755bf..1e5fd5e 100644 --- a/hcdu.cabal +++ b/hcdu.cabal @@ -75,6 +75,7 @@ executable hcdu , extra , directory , vty + , hashmap-io -- Directories containing source files. hs-source-dirs: app