module Graphics.Vty.Widgets.DirBrowser
( DirBrowser(dirBrowserWidget)
, BrowserSkin(..)
, newDirBrowser
, withAnnotations
, setDirBrowserPath
, getDirBrowserPath
, defaultBrowserSkin
, onBrowseAccept
, onBrowseCancel
, onBrowserPathChange
, reportBrowserError
, refreshBrowser
)
where
import Data.IORef
import qualified Data.Map as Map
import Control.Monad
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Graphics.Vty.Widgets.List
import Graphics.Vty.Widgets.Text
import Graphics.Vty.Widgets.Box
import Graphics.Vty.Widgets.Fills
import Graphics.Vty.Widgets.Util
import Graphics.Vty.Widgets.Events
import System.Directory
import System.FilePath
import System.Posix.Files
import System.IO.Error
type T = Widget (Box
(Box (Box FormattedText FormattedText) HFill)
(Box
(List [Char] (Box FormattedText FormattedText))
(Box
(Box (Box FormattedText FormattedText) HFill)
FormattedText)))
data DirBrowser = DirBrowser { dirBrowserWidget :: T
, dirBrowserList :: Widget (List String (Box FormattedText FormattedText))
, dirBrowserPath :: IORef FilePath
, dirBrowserPathDisplay :: Widget FormattedText
, dirBrowserSelectionMap :: IORef (Map.Map FilePath Int)
, dirBrowserFileInfo :: Widget FormattedText
, dirBrowserSkin :: BrowserSkin
, dirBrowserErrorWidget :: Widget FormattedText
, dirBrowserChooseHandlers :: Handlers FilePath
, dirBrowserCancelHandlers :: Handlers FilePath
, dirBrowserPathChangeHandlers :: Handlers FilePath
}
data BrowserSkin = BrowserSkin { browserHeaderAttr :: Attr
, browserUnfocusedSelAttr :: Attr
, browserErrorAttr :: Attr
, browserDirAttr :: Attr
, browserLinkAttr :: Attr
, browserBlockDevAttr :: Attr
, browserNamedPipeAttr :: Attr
, browserCharDevAttr :: Attr
, browserSockAttr :: Attr
, browserCustomAnnotations :: [ (FilePath -> FileStatus -> Bool
, FilePath -> FileStatus -> IO String
, Attr)
]
}
defaultBrowserSkin :: BrowserSkin
defaultBrowserSkin = BrowserSkin { browserHeaderAttr = white `on` blue
, browserUnfocusedSelAttr = bgColor blue
, browserErrorAttr = white `on` red
, browserDirAttr = fgColor green
, browserLinkAttr = fgColor cyan
, browserBlockDevAttr = fgColor red
, browserNamedPipeAttr = fgColor yellow
, browserCharDevAttr = fgColor red
, browserSockAttr = fgColor magenta
, browserCustomAnnotations = []
}
withAnnotations :: BrowserSkin
-> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)]
-> BrowserSkin
withAnnotations sk as = sk { browserCustomAnnotations = browserCustomAnnotations sk ++ as }
newDirBrowser :: BrowserSkin -> IO (DirBrowser, Widget FocusGroup)
newDirBrowser bSkin = do
path <- getCurrentDirectory
pathWidget <- plainText ""
errorText <- plainText "" >>= withNormalAttribute (browserErrorAttr bSkin)
header <- ((plainText " Path: ") <++> (return pathWidget) <++> (hFill ' ' 1))
>>= withNormalAttribute (browserHeaderAttr bSkin)
fileInfo <- plainText ""
footer <- ((plainText " ") <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText))
>>= withNormalAttribute (browserHeaderAttr bSkin)
l <- newList (browserUnfocusedSelAttr bSkin)
ui <- vBox header =<< vBox l footer
r <- newIORef ""
r2 <- newIORef Map.empty
hs <- newHandlers
chs <- newHandlers
pchs <- newHandlers
let b = DirBrowser { dirBrowserWidget = ui
, dirBrowserList = l
, dirBrowserPath = r
, dirBrowserPathDisplay = pathWidget
, dirBrowserSelectionMap = r2
, dirBrowserFileInfo = fileInfo
, dirBrowserSkin = bSkin
, dirBrowserChooseHandlers = hs
, dirBrowserCancelHandlers = chs
, dirBrowserPathChangeHandlers = pchs
, dirBrowserErrorWidget = errorText
}
l `onKeyPressed` handleBrowserKey b
l `onSelectionChange` (\e -> clearError b >> handleSelectionChange b e)
b `onBrowserPathChange` setText (dirBrowserPathDisplay b)
fg <- newFocusGroup
_ <- addToFocusGroup fg l
setDirBrowserPath b path
return (b, fg)
reportBrowserError :: DirBrowser -> String -> IO ()
reportBrowserError b msg = setText (dirBrowserErrorWidget b) $ "Error: " ++ msg
clearError :: DirBrowser -> IO ()
clearError b = setText (dirBrowserErrorWidget b) ""
onBrowseAccept :: DirBrowser -> (FilePath -> IO ()) -> IO ()
onBrowseAccept = addHandler (return . dirBrowserChooseHandlers)
onBrowseCancel :: DirBrowser -> (FilePath -> IO ()) -> IO ()
onBrowseCancel = addHandler (return . dirBrowserCancelHandlers)
onBrowserPathChange :: DirBrowser -> (FilePath -> IO ()) -> IO ()
onBrowserPathChange = addHandler (return . dirBrowserPathChangeHandlers)
cancelBrowse :: DirBrowser -> IO ()
cancelBrowse b = fireEvent b (return . dirBrowserCancelHandlers) =<< getDirBrowserPath b
chooseCurrentEntry :: DirBrowser -> IO ()
chooseCurrentEntry b = do
p <- getDirBrowserPath b
mCur <- getSelected (dirBrowserList b)
case mCur of
Nothing -> return ()
Just (_, (e, _)) -> fireEvent b (return . dirBrowserChooseHandlers) (p </> e)
handleSelectionChange :: DirBrowser -> SelectionEvent String b -> IO ()
handleSelectionChange b ev = do
case ev of
SelectionOff -> setText (dirBrowserFileInfo b) "-"
SelectionOn _ path _ -> setText (dirBrowserFileInfo b) =<< getFileInfo b path
getFileInfo :: DirBrowser -> FilePath -> IO String
getFileInfo b path = do
cur <- getDirBrowserPath b
let newPath = cur </> path
st <- getSymbolicLinkStatus newPath
(_, mkAnn) <- fileAnnotation (dirBrowserSkin b) st cur path
ann <- mkAnn
return $ path ++ ": " ++ ann
builtInAnnotations :: FilePath -> BrowserSkin -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, Attr)]
builtInAnnotations cur sk =
[ (\_ s -> isRegularFile s
, \_ s -> return $ "regular file, " ++
(show $ fileSize s) ++ " bytes"
, def_attr)
, (\_ s -> isSymbolicLink s,
(\p stat -> do
linkDest <- if not $ isSymbolicLink stat
then return ""
else do
linkPath <- readSymbolicLink p
canonicalizePath $ cur </> linkPath
return $ "symbolic link to " ++ linkDest)
, browserLinkAttr sk)
, (\_ s -> isDirectory s, \_ _ -> return "directory", browserDirAttr sk)
, (\_ s -> isBlockDevice s, \_ _ -> return "block device", browserBlockDevAttr sk)
, (\_ s -> isNamedPipe s, \_ _ -> return "named pipe", browserNamedPipeAttr sk)
, (\_ s -> isCharacterDevice s, \_ _ -> return "character device", browserCharDevAttr sk)
, (\_ s -> isSocket s, \_ _ -> return "socket", browserSockAttr sk)
]
fileAnnotation :: BrowserSkin -> FileStatus -> FilePath -> FilePath -> IO (Attr, IO String)
fileAnnotation sk st cur shortPath = do
let fullPath = cur </> shortPath
annotation = getAnnotation' fullPath st $ (browserCustomAnnotations sk) ++
(builtInAnnotations cur sk)
getAnnotation' _ _ [] = (def_attr, return "")
getAnnotation' pth stat ((f,mkAnn,a):rest) =
if f pth stat
then (a, mkAnn pth stat)
else getAnnotation' pth stat rest
return annotation
handleBrowserKey :: DirBrowser -> Widget (List a b) -> Key -> [Modifier] -> IO Bool
handleBrowserKey b _ KEnter [] = descend b True >> return True
handleBrowserKey b _ KRight [] = descend b False >> return True
handleBrowserKey b _ KLeft [] = ascend b >> return True
handleBrowserKey b _ KEsc [] = cancelBrowse b >> return True
handleBrowserKey b _ (KASCII 'q') [] = cancelBrowse b >> return True
handleBrowserKey b _ (KASCII 'r') [] = refreshBrowser b >> return True
handleBrowserKey _ _ _ _ = return False
refreshBrowser :: DirBrowser -> IO ()
refreshBrowser b = setDirBrowserPath b =<< getDirBrowserPath b
setDirBrowserPath :: DirBrowser -> FilePath -> IO ()
setDirBrowserPath b path = do
cPath <- canonicalizePath path
(res, entries) <- (do
entries <- getDirectoryContents cPath
return (True, entries))
`catch` \e -> do
reportBrowserError b (ioeGetErrorString e)
return (False, [])
when res $ do
cur <- getDirBrowserPath b
mCur <- getSelected (dirBrowserList b)
case mCur of
Nothing -> return ()
Just (i, _) -> storeSelection b cur i
clearList (dirBrowserList b)
modifyIORef (dirBrowserPath b) $ const cPath
load b cPath entries
sel <- getSelection b path
case sel of
Nothing -> return ()
Just i -> scrollBy (dirBrowserList b) i
fireEvent b (return . dirBrowserPathChangeHandlers) cPath
getDirBrowserPath :: DirBrowser -> IO FilePath
getDirBrowserPath = readIORef . dirBrowserPath
storeSelection :: DirBrowser -> FilePath -> Int -> IO ()
storeSelection b path i =
modifyIORef (dirBrowserSelectionMap b) $ \m -> Map.insert path i m
getSelection :: DirBrowser -> FilePath -> IO (Maybe Int)
getSelection b path = do
st <- readIORef (dirBrowserSelectionMap b)
return $ Map.lookup path st
load :: DirBrowser -> FilePath -> [FilePath] -> IO ()
load b cur entries =
forM_ entries $ \entry -> do
let fullPath = cur </> entry
f <- getSymbolicLinkStatus fullPath
(attr, _) <- fileAnnotation (dirBrowserSkin b) f cur entry
w <- plainText " " <++> plainText entry
addToList (dirBrowserList b) entry w
ch <- getSecondChild w
setNormalAttribute ch attr
descend :: DirBrowser -> Bool -> IO ()
descend b shouldSelect = do
base <- getDirBrowserPath b
mCur <- getSelected (dirBrowserList b)
case mCur of
Nothing -> return ()
Just (_, (p, _)) -> do
let newPath = base </> p
e <- doesDirectoryExist newPath
case e of
True -> do
cPath <- canonicalizePath newPath
cur <- getDirBrowserPath b
when (cur /= cPath) $ do
case takeDirectory cur == cPath of
True -> ascend b
False -> setDirBrowserPath b cPath
False -> when shouldSelect $ chooseCurrentEntry b
ascend :: DirBrowser -> IO ()
ascend b = do
cur <- getDirBrowserPath b
let newPath = takeDirectory cur
when (newPath /= cur) $
setDirBrowserPath b newPath