(・・;)ゞ

This commit is contained in:
pingu 2023-10-14 13:35:22 +02:00
parent 95b7cf36aa
commit 966744f709
2 changed files with 59 additions and 1 deletions

View File

@ -7,6 +7,8 @@ import Data.Functor ( (<&>) )
import Control.Monad ( filterM ) import Control.Monad ( filterM )
import System.Directory.Extra ( listContents ) import System.Directory.Extra ( listContents )
import Brick import Brick
import Graphics.Vty
import Data.List.Extra
listNonSymFiles :: FilePath -> IO [FilePath] listNonSymFiles :: FilePath -> IO [FilePath]
listNonSymFiles dir = filterM (fmap not . pathIsSymbolicLink) =<< filterM doesFileExist =<< listContents dir listNonSymFiles dir = filterM (fmap not . pathIsSymbolicLink) =<< filterM doesFileExist =<< listContents dir
@ -19,9 +21,61 @@ getSizeSubpaths x = do
sub <- listNonSymDirectories x sub <- listNonSymDirectories x
subby <- mapM (\y -> (y,) . sum . map snd <$> getSizeSubpaths y) sub subby <- mapM (\y -> (y,) . sum . map snd <$> getSizeSubpaths y) sub
local <- listNonSymFiles x >>= (\y -> mapM getFileSize y <&> zip y) local <- listNonSymFiles x >>= (\y -> mapM getFileSize y <&> zip y)
return $ local ++ subby pure $ 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 :: IO ()
main = do main = do
a <- getWorkingDirectory a <- getWorkingDirectory
print =<< getSizeSubpaths a print =<< getSizeSubpaths a
defaultMain app ()

View File

@ -74,9 +74,13 @@ executable hcdu
, unix , unix
, extra , extra
, directory , directory
, vty
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: app hs-source-dirs: app
-- Base language which the package is written in. -- Base language which the package is written in.
default-language: GHC2021 default-language: GHC2021
ghc-options:
-threaded