DirBrowser.hs

{-# LANGUAGE OverloadedStrings #-}
-- |This module provides a directory browser interface widget.  For
-- full details, please see the Vty-ui User's Manual.
module Graphics.Vty.Widgets.DirBrowser
    ( DirBrowser(dirBrowserWidget)
    , BrowserSkin(..)
    , DirBrowserWidgetType
    , newDirBrowser
    , withAnnotations
    , setDirBrowserPath
    , getDirBrowserPath
    , defaultBrowserSkin
    , onBrowseAccept
    , onBrowseCancel
    , onBrowserPathChange
    , reportBrowserError
    , refreshBrowser
    )
where

import Data.IORef
import qualified Data.Map as Map
import qualified Control.Exception as E
import Control.Monad
import qualified Data.Text as T
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 DirBrowserWidgetType =
    Box
    (Box (Box FormattedText FormattedText) HFill)
    (Box
     (List [Char] (Box FormattedText FormattedText))
     (Box
      (Box (Box FormattedText FormattedText) HFill)
      FormattedText))

data DirBrowser = DirBrowser { dirBrowserWidget :: Widget DirBrowserWidgetType
                             , 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
                             }

-- |The collection of attributes and annotations used to determine the
-- browser's visual appearance.
data BrowserSkin = BrowserSkin { browserHeaderAttr :: Attr
                               -- ^Used for the header and footer
                               -- areas of the interface.
                               , browserUnfocusedSelAttr :: Attr
                               -- ^Used for the selected entry when
                               -- the browser does not have focus.
                               , browserErrorAttr :: Attr
                               -- ^Used for the browser's
                               -- error-reporting area.
                               , browserDirAttr :: Attr
                               -- ^Used for directory entries.
                               , browserLinkAttr :: Attr
                               -- ^Used for symbolic link entries.
                               , browserBlockDevAttr :: Attr
                               -- ^Used for block device entries.
                               , browserNamedPipeAttr :: Attr
                               -- ^Used for named pipe entries.
                               , browserCharDevAttr :: Attr
                               -- ^Used for device entries.
                               , browserSockAttr :: Attr
                               -- ^Used for socket entries.
                               , browserShowHeader :: Bool
                               -- ^Whether the browser header should
                               -- be shown.
                               , browserShowFooter :: Bool
                               -- ^Whether the browser footer should
                               -- be shown.
                               , browserCustomAnnotations :: [ (FilePath -> FileStatus -> Bool
                                                               , FilePath -> FileStatus -> IO T.Text
                                                               , Attr)
                                                             ]
                               -- ^File annotations.
                               , browserIncludeEntry :: FilePath -> FileStatus -> Bool
                               -- ^The predicate which determines
                               -- which entries get listed in the
                               -- browser.
                               }

-- |The default browser skin with (hopefully) sane attribute defaults.
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
                                 , browserShowHeader = True
                                 , browserShowFooter = True
                                 , browserCustomAnnotations = []
                                 , browserIncludeEntry = (const . const) True
                                 }

-- |Apply annotations to a browser skin.
withAnnotations :: BrowserSkin
                -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO T.Text, Attr)]
                -> BrowserSkin
withAnnotations sk as = sk { browserCustomAnnotations = browserCustomAnnotations sk ++ as }

-- |Create a directory browser widget with the specified skin.
-- Returns the browser itself along with its focus group.
newDirBrowser :: BrowserSkin -> IO (DirBrowser, Widget FocusGroup)
newDirBrowser bSkin = do
  path <- getCurrentDirectory
  pathWidget <- plainText T.empty
  errorText <- plainText T.empty >>= withNormalAttribute (browserErrorAttr bSkin)
  header <- ((plainText " Path: ")
             <++> (return pathWidget) <++> (hFill ' ' 1))
            >>= withNormalAttribute (browserHeaderAttr bSkin)

  fileInfo <- plainText T.empty
  footer <- ((plainText " ")
             <++> (return fileInfo) <++> (hFill ' ' 1) <++> (return errorText))
            >>= withNormalAttribute (browserHeaderAttr bSkin)

  l <- newList 1
  setSelectedUnfocusedAttr l $ Just (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) . T.pack)

  setVisible header $ browserShowHeader bSkin
  setVisible footer $ browserShowFooter bSkin

  fg <- newFocusGroup
  _ <- addToFocusGroup fg ui

  setDirBrowserPath b path
  return (b, fg)

-- |Report an error in the browser's error-reporting area.  Useful for
-- reporting application-specific errors with the user's file
-- selection.
reportBrowserError :: DirBrowser -> T.Text -> IO ()
reportBrowserError b msg = setText (dirBrowserErrorWidget b) $
                           T.concat [ "Error: "
                                    , msg
                                    ]

clearError :: DirBrowser -> IO ()
clearError b = setText (dirBrowserErrorWidget b) T.empty

-- |Register handlers to be invoked when the user makes a selection.
onBrowseAccept :: DirBrowser -> (FilePath -> IO ()) -> IO ()
onBrowseAccept = addHandler (return . dirBrowserChooseHandlers)

-- |Register handlers to be invoked when the user cancels browsing.
onBrowseCancel :: DirBrowser -> (FilePath -> IO ()) -> IO ()
onBrowseCancel = addHandler (return . dirBrowserCancelHandlers)

-- |Register handlers to be invoked when the browser's path changes.
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 T.Text
getFileInfo b path = do
  cur <- getDirBrowserPath b
  let newPath = cur </> path
  st <- getSymbolicLinkStatus newPath
  (_, mkAnn) <- fileAnnotation (dirBrowserSkin b) st cur path
  ann <- mkAnn
  return $ T.concat [ T.pack (path ++ ": ")
                    , ann
                    ]

builtInAnnotations :: FilePath -> BrowserSkin -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO T.Text, Attr)]
builtInAnnotations cur sk =
    [ (\_ s -> isRegularFile s
      , \_ s -> return $ T.pack $ "regular file, " ++
                (show $ fileSize s) ++ " bytes"
      , defAttr)
    , (\_ s -> isSymbolicLink s,
       (\p stat -> do
          linkDest <- if not $ isSymbolicLink stat
                      then return ""
                      else do
                        linkPath <- readSymbolicLink p
                        canonicalizePath $ cur </> linkPath
          return $ T.pack $ "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 T.Text)
fileAnnotation sk st cur shortPath = do
  let fullPath = cur </> shortPath

      annotation = getAnnotation' fullPath st $ (browserCustomAnnotations sk) ++
                   (builtInAnnotations cur sk)

      getAnnotation' _ _ [] = (defAttr, return T.empty)
      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 _ (KChar 'q') [] = cancelBrowse b >> return True
handleBrowserKey b _ (KChar 'r') [] = refreshBrowser b >> return True
handleBrowserKey _ _ _ _ = return False

-- |Refresh the browser by reloading and displaying the contents of
-- the browser's current path.
refreshBrowser :: DirBrowser -> IO ()
refreshBrowser b = setDirBrowserPath b =<< getDirBrowserPath b

-- |Set the browser's current path.
setDirBrowserPath :: DirBrowser -> FilePath -> IO ()
setDirBrowserPath b path = do
  cPath <- canonicalizePath path

  -- If for some reason we can't load the directory, report an error
  -- and don't change the browser state.
  (res, entries) <- (do
                      entries <- getDirectoryContents cPath
                      return (True, entries))
                     `E.catch` \e -> do
                             reportBrowserError b (T.pack $ ioeGetErrorString e)
                             return (False, [])

  when res $ do
    -- If something is currently selected, store that in the selection
    -- map before changing the path.
    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

-- |Get the browser's current path.
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
      when (browserIncludeEntry (dirBrowserSkin b) fullPath f) $
           do
             (attr, _) <- fileAnnotation (dirBrowserSkin b) f cur entry
             w <- plainText " " <++> plainText (T.pack 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