hcdu/app/Main.hs
2023-10-14 13:50:25 +02:00

85 lines
2.5 KiB
Haskell

module Main where
import System.Posix.Directory ( getWorkingDirectory )
import System.Directory ( pathIsSymbolicLink
, doesFileExist
, getFileSize
, doesDirectoryExist )
import Data.Functor ( (<&>) )
import Control.Monad ( filterM )
import System.Directory.Extra ( listContents )
import Brick
import Graphics.Vty
import Data.List.Extra
import qualified Data.Ord
listNonSymFiles :: FilePath -> IO [FilePath]
listNonSymFiles dir = filterM (fmap not . pathIsSymbolicLink) =<< filterM doesFileExist =<< listContents dir
listNonSymDirectories :: FilePath -> IO [FilePath]
listNonSymDirectories dir = filterM (fmap not . pathIsSymbolicLink) =<< filterM doesDirectoryExist =<< listContents dir
getSizeSubpaths :: FilePath -> IO [(FilePath, Integer)]
getSizeSubpaths x = do
sub <- listNonSymDirectories x
subby <- mapM (\y -> (y,) . sum . map snd <$> getSizeSubpaths y) sub
local <- listNonSymFiles x >>= (\y -> mapM getFileSize y <&> zip y)
pure $ sortOn (Data.Ord.Down . snd) $ local ++ subby
data AppS = AppS
{
_appCWD :: FilePath
, _appCursor :: Int
, _appFocus :: Maybe FilePath
, _appSubFiles :: [(FilePath, Integer)]
}
data ScrollDirection where
SUp :: ScrollDirection
SDown :: ScrollDirection
ui :: Widget ()
ui = viewport () Vertical $ str "Svamp är gott"
app :: App () e ()
app =
App { appDraw = const [ui]
, appHandleEvent = resizeOrQuit
, appStartEvent = pure ()
, appAttrMap = const $ attrMap (white `on` blue) []
, appChooseCursor = neverShowCursor
}
sizeDir :: AppS -> IO AppS
sizeDir s = do
subFiles <- getSizeSubpaths $ _appCWD s
pure $ s {_appSubFiles = subFiles}
changeDir :: AppS -> FilePath -> IO AppS
changeDir so f =
let s = so {
_appCWD = f
, _appSubFiles = []
} in
sizeDir s
scroll :: ScrollDirection -> AppS -> AppS
scroll d s = s {
_appCursor = newCursor
, _appFocus = maybeNewPath
}
where cursor =
_appCursor s +
case d of
SUp -> (-1)
SDown -> 1
newCursor = max 0 (min ((-) 1 . length $ _appSubFiles s) cursor)
maybeNewPath = fst <$> _appSubFiles s !? newCursor
main :: IO ()
main = do
a <- getWorkingDirectory
print =<< getSizeSubpaths a
defaultMain app ()