module Graphics.Vty.Widgets.List
( List
, ListItem
, ListError(..)
, NewItemEvent(..)
, RemoveItemEvent(..)
, SelectionEvent(..)
, ActivateItemEvent(..)
, newStringList
, newList
, addToList
, removeFromList
, scrollBy
, scrollUp
, scrollDown
, pageUp
, pageDown
, onSelectionChange
, onItemAdded
, onItemRemoved
, onItemActivated
, activateCurrentItem
, clearList
, getListSize
, getSelected
)
where
import Data.Typeable
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Monad.Trans
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Graphics.Vty.Widgets.Text
import Graphics.Vty.Widgets.Events
import Graphics.Vty.Widgets.Util
data ListError = BadItemIndex Int
| ResizeError
| BadListWidgetSizePolicy
deriving (Show, Typeable)
instance Exception ListError
type ListItem a b = (a, Widget b)
data SelectionEvent a b = SelectionOn Int a (Widget b)
| SelectionOff
data NewItemEvent a b = NewItemEvent Int a (Widget b)
data RemoveItemEvent a b = RemoveItemEvent Int a (Widget b)
data ActivateItemEvent a b = ActivateItemEvent Int a (Widget b)
data List a b = List { selectedUnfocusedAttr :: Attr
, selectedIndex :: Int
, scrollTopIndex :: Int
, scrollWindowSize :: Int
, listItems :: [ListItem a b]
, selectionChangeHandlers :: Handlers (SelectionEvent a b)
, itemAddHandlers :: Handlers (NewItemEvent a b)
, itemRemoveHandlers :: Handlers (RemoveItemEvent a b)
, itemActivateHandlers :: Handlers (ActivateItemEvent a b)
, itemHeight :: Int
, itemConstructor :: a -> IO (Widget b)
}
instance Show (List a b) where
show lst = concat [ "List { "
, "selectedUnfocusedAttr = ", show $ selectedUnfocusedAttr lst
, ", selectedIndex = ", show $ selectedIndex lst
, ", scrollTopIndex = ", show $ scrollTopIndex lst
, ", scrollWindowSize = ", show $ scrollWindowSize lst
, ", listItems = <", show $ length $ listItems lst, " items>"
, ", itemHeight = ", show $ itemHeight lst
, " }"
]
newListData :: (MonadIO m) =>
Attr
-> (a -> IO (Widget b))
-> m (List a b)
newListData selAttr f = do
schs <- newHandlers
iahs <- newHandlers
irhs <- newHandlers
iacths <- newHandlers
return $ List { selectedUnfocusedAttr = selAttr
, selectedIndex = 1
, scrollTopIndex = 0
, scrollWindowSize = 0
, listItems = []
, selectionChangeHandlers = schs
, itemAddHandlers = iahs
, itemRemoveHandlers = irhs
, itemActivateHandlers = iacths
, itemHeight = 0
, itemConstructor = f
}
getListSize :: (MonadIO m) => Widget (List a b) -> m Int
getListSize = ((length . listItems) <~~)
removeFromList :: (MonadIO m) => Widget (List a b) -> Int -> m (ListItem a b)
removeFromList list pos = do
st <- getState list
let numItems = length $ listItems st
oldScr = scrollTopIndex st
when (pos < 0 || pos >= numItems) $
throw $ BadItemIndex pos
let (label, w) = listItems st !! pos
sel = selectedIndex st
newScrollTop = if pos <= oldScr
then if oldScr == 0
then oldScr
else oldScr 1
else oldScr
newSelectedIndex = if pos > sel
then sel
else if pos < sel
then if sel == 0
then 0
else sel 1
else if sel == 0
then if numItems == 1
then (1)
else 0
else if sel == numItems 1
then sel 1
else sel
updateWidgetState list $ \s -> s { selectedIndex = newSelectedIndex
, listItems = take pos (listItems st) ++
drop (pos + 1) (listItems st)
, scrollTopIndex = newScrollTop
}
notifyItemRemoveHandler list pos label w
when (pos <= selectedIndex st) $
notifySelectionHandler list
return (label, w)
addToList :: (MonadIO m, Show b) => Widget (List a b) -> a -> m (ListItem a b)
addToList list key = do
numItems <- (length . listItems) <~~ list
makeWidget <- itemConstructor <~~ list
w <- liftIO $ makeWidget key
v <- growVertical w
when (v) $ throw BadListWidgetSizePolicy
h <- case numItems of
0 -> do
img <- render w (DisplayRegion 100 100) defaultContext
return $ fromEnum $ image_height img
_ -> itemHeight <~~ list
updateWidgetState list $ \s -> s { itemHeight = h
, listItems = listItems s ++ [(key, w)]
, selectedIndex = if numItems == 0
then 0
else selectedIndex s
}
notifyItemAddHandler list (numItems + 1) key w
when (numItems == 0) $
notifySelectionHandler list
return (key, w)
onSelectionChange :: (MonadIO m) =>
Widget (List a b)
-> (SelectionEvent a b -> IO ())
-> m ()
onSelectionChange = addHandler (selectionChangeHandlers <~~)
onItemAdded :: (MonadIO m) => Widget (List a b)
-> (NewItemEvent a b -> IO ()) -> m ()
onItemAdded = addHandler (itemAddHandlers <~~)
onItemRemoved :: (MonadIO m) => Widget (List a b)
-> (RemoveItemEvent a b -> IO ()) -> m ()
onItemRemoved = addHandler (itemRemoveHandlers <~~)
onItemActivated :: (MonadIO m) => Widget (List a b)
-> (ActivateItemEvent a b -> IO ()) -> m ()
onItemActivated = addHandler (itemActivateHandlers <~~)
clearList :: (MonadIO m) => Widget (List a b) -> m ()
clearList w = do
updateWidgetState w $ \l ->
l { selectedIndex = (1)
, scrollTopIndex = 0
, listItems = []
}
newList :: (MonadIO m, Show b) =>
Attr
-> (a -> IO (Widget b))
-> m (Widget (List a b))
newList selAttr f = do
list <- newListData selAttr f
wRef <- newWidget $ \w ->
w { state = list
, keyEventHandler = listKeyEvent
, growVertical_ = const $ return True
, growHorizontal_ = const $ return True
, getCursorPosition_ =
\this -> do
st <- getState this
pos <- getCurrentPosition this
sz <- getCurrentSize this
let newCol = max 0 (region_width pos + region_width sz 1)
newRow = region_height pos + toEnum (max 0 $ selectedIndex st scrollTopIndex st)
return $ Just (pos `withWidth` newCol `withHeight` newRow)
, render_ =
\this sz ctx -> do
h <- itemHeight <~~ this
when (h > 0) $
resize this (max 1 ((fromEnum $ region_height sz) `div` h))
listData <- getState this
foc <- focused <~ this
renderListWidget foc listData sz ctx
, setCurrentPosition_ =
\this pos -> do
ih <- itemHeight <~~ this
items <- getVisibleItems this
forM_ (zip [0..] items) $ \(i, ((_, iw), _)) ->
setCurrentPosition iw (pos `plusHeight` (toEnum $ i * ih))
}
return wRef
listKeyEvent :: Widget (List a b) -> Key -> [Modifier] -> IO Bool
listKeyEvent w KUp _ = scrollUp w >> return True
listKeyEvent w KDown _ = scrollDown w >> return True
listKeyEvent w KPageUp _ = pageUp w >> return True
listKeyEvent w KPageDown _ = pageDown w >> return True
listKeyEvent w KEnter _ = activateCurrentItem w >> return True
listKeyEvent _ _ _ = return False
renderListWidget :: (Show b) => Bool -> List a b -> DisplayRegion -> RenderContext -> IO Image
renderListWidget foc list s ctx = do
let items = map (\((_, w), sel) -> (w, sel)) $ getVisibleItems_ list
defaultAttr = mergeAttrs [ overrideAttr ctx
, normalAttr ctx
]
renderVisible [] = return []
renderVisible ((w, sel):ws) = do
let att = if sel
then if foc
then focusAttr ctx
else mergeAttrs [ selectedUnfocusedAttr list
, defaultAttr
]
else defaultAttr
img <- render w s $ ctx { overrideAttr = att }
let actualHeight = min (region_height s) (toEnum $ itemHeight list)
img' = img <|> char_fill att ' '
(region_width s image_width img)
actualHeight
imgs <- renderVisible ws
return (img':imgs)
let filler = char_fill defaultAttr ' ' (region_width s) fill_height
fill_height = if scrollWindowSize list == 0
then region_height s
else toEnum $ ((scrollWindowSize list length items) * itemHeight list)
visible_imgs <- renderVisible items
return $ vert_cat (visible_imgs ++ [filler])
newStringList :: (MonadIO m) =>
Attr
-> [String]
-> m (Widget (List String FormattedText))
newStringList selAttr labels = do
list <- newList selAttr plainText
mapM_ (addToList list) labels
return list
activateCurrentItem :: (MonadIO m) => Widget (List a b) -> m ()
activateCurrentItem wRef = do
mSel <- getSelected wRef
case mSel of
Nothing -> return ()
Just (pos, (val, w)) ->
fireEvent wRef (itemActivateHandlers <~~) $ ActivateItemEvent pos val w
getSelected :: (MonadIO m) => Widget (List a b) -> m (Maybe (Int, ListItem a b))
getSelected wRef = do
list <- state <~ wRef
case selectedIndex list of
(1) -> return Nothing
i -> return $ Just (i, (listItems list) !! i)
resize :: (MonadIO m) => Widget (List a b) -> Int -> m ()
resize wRef newSize = do
when (newSize == 0) $ throw ResizeError
size <- (scrollWindowSize . state) <~ wRef
case compare newSize size of
EQ -> return ()
GT -> updateWidgetState wRef $ \list ->
list { scrollWindowSize = newSize
, scrollTopIndex = max 0 (scrollTopIndex list (newSize scrollWindowSize list))
}
LT -> do
list <- state <~ wRef
let newBottomPosition = scrollTopIndex list + newSize 1
current = selectedIndex list
newScrollTopIndex = if current > newBottomPosition
then current newSize + 1
else scrollTopIndex list
updateWidgetState wRef $ const $ list { scrollWindowSize = newSize
, scrollTopIndex = newScrollTopIndex
}
scrollBy :: (MonadIO m) => Widget (List a b) -> Int -> m ()
scrollBy wRef amount = do
updateWidgetState wRef $ scrollBy' amount
notifySelectionHandler wRef
scrollBy' :: Int -> List a b -> List a b
scrollBy' amount list =
let sel = selectedIndex list
lastPos = (length $ listItems list) 1
validPositions = [0..lastPos]
newPosition = sel + amount
newSelected = if newPosition `elem` validPositions
then newPosition
else if newPosition > lastPos
then lastPos
else 0
bottomPosition = min (scrollTopIndex list + scrollWindowSize list 1)
((length $ listItems list) 1)
topPosition = scrollTopIndex list
windowPositions = [topPosition..bottomPosition]
adjustedTop = if newSelected `elem` windowPositions
then topPosition
else if newSelected >= bottomPosition
then newSelected scrollWindowSize list + 1
else newSelected
in if scrollWindowSize list == 0
then list
else list { scrollTopIndex = adjustedTop
, selectedIndex = newSelected }
notifySelectionHandler :: (MonadIO m) => Widget (List a b) -> m ()
notifySelectionHandler wRef = do
sel <- getSelected wRef
case sel of
Nothing ->
fireEvent wRef (selectionChangeHandlers <~~) SelectionOff
Just (pos, (a, b)) ->
fireEvent wRef (selectionChangeHandlers <~~) $ SelectionOn pos a b
notifyItemRemoveHandler :: (MonadIO m) => Widget (List a b) -> Int -> a -> Widget b -> m ()
notifyItemRemoveHandler wRef pos k w =
fireEvent wRef (itemRemoveHandlers <~~) $ RemoveItemEvent pos k w
notifyItemAddHandler :: (MonadIO m) => Widget (List a b) -> Int -> a -> Widget b -> m ()
notifyItemAddHandler wRef pos k w =
fireEvent wRef (itemAddHandlers <~~) $ NewItemEvent pos k w
scrollDown :: (MonadIO m) => Widget (List a b) -> m ()
scrollDown wRef = scrollBy wRef 1
scrollUp :: (MonadIO m) => Widget (List a b) -> m ()
scrollUp wRef = scrollBy wRef (1)
pageDown :: (MonadIO m) => Widget (List a b) -> m ()
pageDown wRef = do
amt <- scrollWindowSize <~~ wRef
scrollBy wRef amt
pageUp :: (MonadIO m) => Widget (List a b) -> m ()
pageUp wRef = do
amt <- scrollWindowSize <~~ wRef
scrollBy wRef (1 * amt)
getVisibleItems :: (MonadIO m) => Widget (List a b) -> m [(ListItem a b, Bool)]
getVisibleItems wRef = do
list <- state <~ wRef
return $ getVisibleItems_ list
getVisibleItems_ :: List a b -> [(ListItem a b, Bool)]
getVisibleItems_ list =
let start = scrollTopIndex list
stop = scrollTopIndex list + scrollWindowSize list
adjustedStop = (min stop $ length $ listItems list) 1
in [ (listItems list !! i, i == selectedIndex list)
| i <- [start..adjustedStop] ]