hcdu/app/Main.hs

{-# LANGUAGE BlockArguments #-}
module Main where

import           System.Posix.Directory ( getWorkingDirectory, changeWorkingDirectory )
import           System.Directory       ( pathIsSymbolicLink
                                        , doesFileExist
                                        , getFileSize
                                        , doesDirectoryExist )
import           Data.Functor           ( (<&>) )
import           Control.Monad          ( filterM )
import           Control.Monad.IO.Class
import           System.Directory.Extra ( listContents )
import           System.IO.Error
import           Brick
import           Brick.Widgets.Edit
import           Graphics.Vty
import           Data.List.Extra
import qualified Data.Ord
import           Data.Maybe


listNonSymFiles :: FilePath -> IO [FilePath]
listNonSymFiles dir = filterM ((not <$>) . pathIsSymbolicLink) =<< filterM doesFileExist =<< listContents dir

listNonSymDirectories :: FilePath -> IO [FilePath]
listNonSymDirectories dir = filterM ((not <$>) . pathIsSymbolicLink) =<< filterM doesDirectoryExist =<< listContents dir

listSym :: FilePath -> IO [FilePath]
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]


data ScrollDirection where
  SUp   :: ScrollDirection
  SDown :: ScrollDirection

data AppS = AppS
  {
    _appCWD :: FilePath
  , _appCursor :: Int
  , _appFocus :: Maybe FilePath
  , _appSubFiles :: [(FilePath, Integer)]
  }

app :: App AppS e ()
app =
    App { appDraw = pure . browse
        , appHandleEvent = eventHandler
        , appStartEvent = pure ()
        , appAttrMap = attributeMap
        , appChooseCursor = showFirstCursor
        }

attributeMap :: AppS -> AttrMap
attributeMap = const $ attrMap defAttr
                  [ (attrName "selected", withStyle defAttr reverseVideo)
                  , (editAttr, fg brightBlack)
                  ]

select :: Widget () -> Widget ()
select = withAttr (attrName "selected")

browse :: AppS -> Widget ()
browse s =
  str "Path" <+> padLeft Max (str "Size") <=>
  viewport () Vertical (foldr (widgetCons s) emptyWidget (_appSubFiles s))

widgetCons :: AppS -> (FilePath, Integer) -> Widget () -> Widget ()
widgetCons s w@(f,_) ws =
  (<=> ws) if Just f == _appFocus s then
           select . visible $ pathWidget w else
           pathWidget w

pathWidget :: (FilePath, Integer) -> Widget ()
pathWidget (f, s) = str (show f) <+> padLeft Max (str (show s))

sizeDir :: AppS -> IO AppS
sizeDir s = do
  subFiles <- getSizeSubpaths $ _appCWD s
  pure $
    s {
        _appCursor = 0
      , _appFocus = map fst subFiles !? 0
      , _appSubFiles = subFiles
      }

changeDir :: AppS -> IO AppS
changeDir so
  | isJust $ _appFocus so = do
    allowed <- doesDirectoryExist path
    if allowed then do
      changeWorkingDirectory path
      let s =
            so {
                _appCWD       = path
              , _appSubFiles  = []
              } in
                sizeDir s else
      pure so
  | otherwise             = pure so
  where path = fromJust $ _appFocus so

overDir :: IO AppS
overDir = do
  changeWorkingDirectory ".."
  a <- getWorkingDirectory
  changeDir $ initialState a

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 (subtract 1 . length $ _appSubFiles s) cursor)
        maybeNewPath = fst <$> _appSubFiles s !? newCursor

eventHandler :: BrickEvent () e -> EventM () AppS ()
eventHandler (VtyEvent (EvKey k _)) = do
  s <- get
  case k of
      (KChar 'q') -> halt
      KEsc        -> halt

      (KChar 'j') -> put $ scroll SDown s
      (KChar 'k') -> put $ scroll SUp s
      KDown       -> put $ scroll SDown s
      KUp         -> put $ scroll SUp s

      (KChar 'h') -> put =<< liftIO overDir
      KLeft       -> put =<< liftIO overDir

      (KChar ' ') -> put =<< liftIO (changeDir s)
      KEnter      -> put =<< liftIO (changeDir s)
      (KChar 'l') -> put =<< liftIO (changeDir s)
      KRight      -> put =<< liftIO (changeDir s)

      _           -> continueWithoutRedraw

eventHandler _ = undefined

initialState :: FilePath -> AppS
initialState f =
  AppS {
          _appCWD = f
        , _appCursor = 0
        , _appFocus = pure f
        , _appSubFiles = []
        }

main :: IO ()
main = do
  a <- getWorkingDirectory
  b <- changeDir $ initialState a
  _ <- defaultMain app b
  return ()