module Graphics.Vty.Widgets.List
( List
, ListItem
, ListError(..)
, NewItemEvent(..)
, RemoveItemEvent(..)
, SelectionEvent(..)
, ActivateItemEvent(..)
, newTextList
, newList
, addToList
, insertIntoList
, removeFromList
, scrollBy
, scrollUp
, scrollDown
, pageUp
, pageDown
, onSelectionChange
, onItemAdded
, onItemRemoved
, onItemActivated
, activateCurrentItem
, clearList
, setSelected
, getListSize
, getSelected
, getListItem
)
where
import Data.Typeable
import Control.Exception hiding (Handler)
import Control.Monad
import qualified Data.Text as T
import qualified Data.Vector as V
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 :: V.Vector (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
}
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 $ V.length $ listItems lst, " items>"
, ", itemHeight = ", show $ itemHeight lst
, " }"
]
newListData :: Attr
-> IO (List a b)
newListData selAttr = do
schs <- newHandlers
iahs <- newHandlers
irhs <- newHandlers
iacths <- newHandlers
return $ List { selectedUnfocusedAttr = selAttr
, selectedIndex = 1
, scrollTopIndex = 0
, scrollWindowSize = 0
, listItems = V.empty
, selectionChangeHandlers = schs
, itemAddHandlers = iahs
, itemRemoveHandlers = irhs
, itemActivateHandlers = iacths
, itemHeight = 0
}
getListSize :: Widget (List a b) -> IO Int
getListSize = ((V.length . listItems) <~~)
removeFromList :: Widget (List a b) -> Int -> IO (ListItem a b)
removeFromList list pos = do
st <- getState list
foc <- focused <~ list
let numItems = V.length $ listItems st
oldScr = scrollTopIndex st
when (pos < 0 || pos >= numItems) $
throw $ BadItemIndex pos
let (label, w) = (listItems st) V.! 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 = V.take pos (listItems st) V.++
V.drop (pos + 1) (listItems st)
, scrollTopIndex = newScrollTop
}
when foc $ do
when (pos == sel) $ do
unfocus w
cur <- getSelected list
case cur of
Nothing -> return ()
Just (_, (_, w')) -> focus w'
notifyItemRemoveHandler list pos label w
when (pos <= selectedIndex st) $
notifySelectionHandler list
return (label, w)
addToList :: (Show b) => Widget (List a b) -> a -> Widget b -> IO ()
addToList list key w = do
numItems <- (V.length . listItems) <~~ list
insertIntoList list key w numItems
insertIntoList :: (Show b) => Widget (List a b) -> a -> Widget b -> Int -> IO ()
insertIntoList list key w pos = do
numItems <- (V.length . listItems) <~~ list
v <- growVertical w
when (v) $ throw BadListWidgetSizePolicy
h <- case numItems of
0 -> do
img <- render w (DisplayRegion 100 100) defaultContext
return $ max 1 $ fromEnum $ image_height img
_ -> itemHeight <~~ list
oldSel <- selectedIndex <~~ list
oldScr <- scrollTopIndex <~~ list
swSize <- scrollWindowSize <~~ list
let newSelIndex = if numItems == 0
then 0
else if pos <= oldSel
then oldSel + 1
else oldSel
newScrollTop = if pos <= oldSel
then if (oldSel oldScr + 1) == swSize
then oldScr + 1
else oldScr
else oldScr
let vInject atPos a as = let (hd, t) = (V.take atPos as, V.drop atPos as)
in hd V.++ (V.cons a t)
let newItems s = if pos >= numItems
then V.snoc (listItems s) (key, w)
else vInject pos (key, w) (listItems s)
updateWidgetState list $ \s -> s { itemHeight = h
, listItems = V.force $ newItems s
, selectedIndex = newSelIndex
, scrollTopIndex = newScrollTop
}
notifyItemAddHandler list (numItems + 1) key w
when (numItems == 0) $
do
foc <- focused <~ list
when foc $ focus w
when (oldSel /= newSelIndex) $ notifySelectionHandler list
onSelectionChange :: Widget (List a b)
-> (SelectionEvent a b -> IO ())
-> IO ()
onSelectionChange = addHandler (selectionChangeHandlers <~~)
onItemAdded :: Widget (List a b)
-> (NewItemEvent a b -> IO ()) -> IO ()
onItemAdded = addHandler (itemAddHandlers <~~)
onItemRemoved :: Widget (List a b)
-> (RemoveItemEvent a b -> IO ()) -> IO ()
onItemRemoved = addHandler (itemRemoveHandlers <~~)
onItemActivated :: Widget (List a b)
-> (ActivateItemEvent a b -> IO ()) -> IO ()
onItemActivated = addHandler (itemActivateHandlers <~~)
clearList :: Widget (List a b) -> IO ()
clearList w = do
updateWidgetState w $ \l ->
l { selectedIndex = (1)
, scrollTopIndex = 0
, listItems = V.empty
}
newList :: (Show b) =>
Attr
-> IO (Widget (List a b))
newList selAttr = do
list <- newListData selAttr
wRef <- newWidget list $ \w ->
w { keyEventHandler = listKeyEvent
, growVertical_ = const $ return True
, growHorizontal_ = const $ return True
, getCursorPosition_ =
\this -> do
sel <- getSelected this
case sel of
Nothing -> return Nothing
Just (_, (_, e)) -> getCursorPosition e
, 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))
}
wRef `onGainFocus` \_ ->
do
val <- getSelected wRef
case val of
Nothing -> return ()
Just (_, (_, w)) -> focus w
wRef `onLoseFocus` \_ ->
do
val <- getSelected wRef
case val of
Nothing -> return ()
Just (_, (_, w)) -> unfocus w
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 w k mods = do
val <- getSelected w
case val of
Nothing -> return False
Just (_, (_, e)) -> handleKeyEvent e k mods
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])
newTextList :: Attr
-> [T.Text]
-> IO (Widget (List T.Text FormattedText))
newTextList selAttr labels = do
list <- newList selAttr
forM_ labels $ \l ->
(addToList list l =<< plainText l)
return list
activateCurrentItem :: Widget (List a b) -> IO ()
activateCurrentItem wRef = do
mSel <- getSelected wRef
case mSel of
Nothing -> return ()
Just (pos, (val, w)) ->
fireEvent wRef (itemActivateHandlers <~~) $ ActivateItemEvent pos val w
getSelected :: Widget (List a b) -> IO (Maybe (Int, ListItem a b))
getSelected wRef = do
list <- state <~ wRef
case selectedIndex list of
(1) -> return Nothing
i -> return $ Just (i, (listItems list) V.! i)
getListItem :: Widget (List a b) -> Int -> IO (Maybe (ListItem a b))
getListItem wRef pos = do
list <- state <~ wRef
case pos >= 0 && pos < (V.length $ listItems list) of
False -> return Nothing
True -> return $ Just ((listItems list) V.! pos)
setSelected :: Widget (List a b) -> Int -> IO ()
setSelected wRef newPos = do
list <- state <~ wRef
case selectedIndex list of
(1) -> return ()
curPos -> scrollBy wRef (newPos curPos)
resize :: Widget (List a b) -> Int -> IO ()
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 :: Widget (List a b) -> Int -> IO ()
scrollBy wRef amount = do
foc <- focused <~ wRef
old <- getSelected wRef
case old of
Nothing -> return ()
Just (_, (_, w)) -> when foc $ unfocus w
updateWidgetState wRef $ scrollBy' amount
new <- getSelected wRef
case new of
Nothing -> return ()
Just (_, (_, w)) -> when foc $ focus w
notifySelectionHandler wRef
scrollBy' :: Int -> List a b -> List a b
scrollBy' amount list =
let sel = selectedIndex list
lastPos = (V.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)
((V.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 :: Widget (List a b) -> IO ()
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 :: Widget (List a b) -> Int -> a -> Widget b -> IO ()
notifyItemRemoveHandler wRef pos k w =
fireEvent wRef (itemRemoveHandlers <~~) $ RemoveItemEvent pos k w
notifyItemAddHandler :: Widget (List a b) -> Int -> a -> Widget b -> IO ()
notifyItemAddHandler wRef pos k w =
fireEvent wRef (itemAddHandlers <~~) $ NewItemEvent pos k w
scrollDown :: Widget (List a b) -> IO ()
scrollDown wRef = scrollBy wRef 1
scrollUp :: Widget (List a b) -> IO ()
scrollUp wRef = scrollBy wRef (1)
pageDown :: Widget (List a b) -> IO ()
pageDown wRef = do
amt <- scrollWindowSize <~~ wRef
scrollBy wRef amt
pageUp :: Widget (List a b) -> IO ()
pageUp wRef = do
amt <- scrollWindowSize <~~ wRef
scrollBy wRef (1 * amt)
getVisibleItems :: Widget (List a b) -> IO [(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 $ V.length $ listItems list) 1
in [ (listItems list V.! i, i == selectedIndex list)
| i <- [start..adjustedStop] ]