DirBrowser.hs

-- |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 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 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.
                               , browserCustomAnnotations :: [ (FilePath -> FileStatus -> Bool
                                                               , FilePath -> FileStatus -> IO String
                                                               , Attr)
                                                             ]
                               -- ^File annotations.
                               }

-- |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
                                 , browserCustomAnnotations = []
                                 }

-- |Apply annotations to a browser skin.
withAnnotations :: BrowserSkin
                -> [(FilePath -> FileStatus -> Bool, FilePath -> FileStatus -> IO String, 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 ""
  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)

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

clearError :: DirBrowser -> IO ()
clearError b = setText (dirBrowserErrorWidget b) ""

-- |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 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

-- |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))
                     `catch` \e -> do
                             reportBrowserError b (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
      (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