{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-| Module : ItemField Description : Selectable field of items and their current state Copyright : (c) Kevin Quick, 2016 License : BSD-3 Maintainer : quick@sparq.org Stability : stable Portability : POSIX The ItemField is used to keep track of the current status of a potentially large number of items and visually indicate that status. Further, it provides the ability to move the cursor around in the field of items to "select" a particular item, as well as marking one or more items for performing an operation on. This widget is useful for handling data sets that are too large to readily display with a List widget or similar functionality. Each item is represented by a single character on the screen, and these characters are displayed in the specified groups. Each item can have an associated state, which is reflected in both the character used for that item and the associated attributes: @ State Character Attribute Free (unmarked) . itemFreeAttr Marked * itemMarkedAttr Good + itemGoodAttr Bad ! itemBadAttr Pending ~ itemPendingAttr @ See below for the definitions of these and other attributes that can be controlled by the user. The widget provides a default event handler that handles the following: - Arrow keys: move in the specified direction - Mouse-click: move cursor to clicked item - Space: select/deselect the item under the cursor (state->Marked or Free) - Shift-RightArrow or Shift-LeftArrow: extend selection - < or >: move 15 items backward or forward - L: toggle Marked/Free for the current line - G: toggle Marked/Free for the current group - Mouse-click on a group: toggle Marked/Free for the current group - A: toggle Marked/Free for all items - +: change all Good items to Marked - !: change all Bad items to Marked - ~: change all Pending items to Marked - s: change all Good items to Marked, everything else to Free - f: change all Bad items to Marked, everything else to Free Use @cabal configure -fexamples@ to build a couple of example programs that use the ItemField and demonstrate its capabilities. This module provides the top-level imports and the interaction with the brick UI framework. -} module TextUI.ItemField ( module TextUI.ItemField.Types -- * Types , ItemFieldWidget(..) -- * Rendering , itemFieldWidget #ifdef TEST , itemFieldRender -- export for testing only #endif -- * Event handling , handleItemFieldEvent , withItemFieldWidth -- * Current item retrieval and manipulation , setItemState , getSelectedItem -- * Retrieving and updating marked items , getMarkedItems , setMarkedItemsState , module TextUI.ItemField.Attrs ) where import Brick.AttrMap import Brick.Main (lookupViewport, invalidateCache, invalidateCacheEntry) import Brick.Types import Brick.Widgets.Core import Control.Monad (foldM) import Data.List import Data.Maybe (fromMaybe) import qualified Data.Text as T import Graphics.Vty import Lens.Micro ((^.), _1) import TextUI.ItemField.Attrs import TextUI.ItemField.BrickHelper (getEventWidgetLocation) import TextUI.ItemField.Layout import TextUI.ItemField.Operations import TextUI.ItemField.Types -- | This is the main widget for managing an ItemFieldWidget in a brick UI. data ItemFieldWidget n = ItemFieldWidget { itemFieldName :: n , itemField :: ItemField } instance Show (ItemFieldWidget n) where show = show . itemField instance Named (ItemFieldWidget n) n where getName = itemFieldName -- | This is the primary drawing description for the ItemField. This -- draws the widget in a viewport with the same name as the widget, -- using the Fixed horizontal and vertical growth policies. itemFieldWidget :: (Show n, Ord n) => ItemFieldWidget n -> Widget n itemFieldWidget field = -- n.b. Use "Vertical" and not "Both" and accept "invisible" items if output screen is too narrow. This is better than enabling horizontal scrolling, at which point the group names are never scrolled back into view. could change this by making each group/line scrollable independently... let i = reportExtent (getName field) $ viewport (getName field) Vertical $ cached (getName field) $ Widget Fixed Fixed $ fieldImageW field s = Widget Fixed Fixed . summaryW field in case elemIdent $ itemField field of Nothing -> i Just sf -> i <=> s sf fieldImageW :: ItemFieldWidget n -> RenderM n (Result n) fieldImageW field = do ctx <- getContext let width = ctx^.availWidthL height = ctx^.availHeightL attrmap = ctx^.ctxAttrMapL (rdata, newImage) = itemFieldRender field attrmap width height cursor = CursorLocation cursorloc (Just $ getName field) cursorloc = itemFieldGetPos rdata field return $ Result newImage [cursor] [VR cursorloc (1,1)] [] -- KWQ: VR is internal.. can update with recent brick changes?? summaryW :: ItemFieldWidget n -> (Int -> ItemState -> T.Text) -> RenderM n (Result n) summaryW field fn = do let s' = itemField field cs = curSel s' cs8 = itemst8 s' !! cs render $ identSel cs cs8 fn itemFieldRender :: ItemFieldWidget n -> AttrMap -> Int -> Int -> (RenderData, Graphics.Vty.Image) itemFieldRender field attrs width height = let s' = itemField field rdata = computeLinePosRanges width s' ls = redrawSt8Lines height (items s') (itemst8 s') rdata mkLineImg = horizCat . map mkColImg mkColImg (t,a) = string (attrMapLookup a attrs) $ T.unpack t in (rdata, vertCat $ map mkLineImg ls) identSel :: Int -> ItemState -> (Int -> ItemState -> T.Text) -> Widget n identSel cs cs8 sf = let msg = "#" ++ show cs ++ " " ++ T.unpack (sf cs cs8) in withDefAttr itemSelectedDetailsAttr $ str msg itemFieldGetPos :: RenderData -> ItemFieldWidget n -> Location itemFieldGetPos rdata field = let mbl = pos_coordinates (itemField field) rdata in Location $ fromMaybe (5,0) mbl -- | This is a handler that can be called from a higher level brick -- Event handler to allow the item field to handle any keys or other -- events that have not been handled by that higher level handler. This handler provides handling for: -- -- * movement via arrow keys and the '<' and '>' keys -- * toggling marking items: -- space = current item -- L = current line -- G = current group -- A = all items -- * extending marking by holding shift while using left or right arrow keys -- * marking all items with a particular status by using the corrsponding key: +, !, or ~ -- handleItemFieldEvent :: (Ord n) => Event -> ItemFieldWidget n -> EventM n (ItemFieldWidget n) handleItemFieldEvent event fieldw = let marking mods = MShift `elem` mods allWithState s = elemIndices s $ itemst8 $ itemField fieldw oldItm = itemField fieldw clrItm = setAllFree oldItm onFldWidget fld fun itmLst = let newItm = foldl fun fld itmLst in fieldw { itemField = newItm } markItem = changeItemState Marked handleKey key mods = case key of KRight -> selectNextItem (marking mods) fieldw KLeft -> selectPrevItem (marking mods) fieldw KChar '>' -> selectForwardBy 15 False fieldw KChar '<' -> selectBackwardBy 15 False fieldw -- -- shift + KUp or KDown is not supported, so just do regular movement KDown -> withItemFieldWidth fieldw $ \w -> selectNextLineItem w False fieldw KUp -> withItemFieldWidth fieldw $ \w -> selectPrevLineItem w False fieldw -- marked item toggling: space = single item, L = line, G = current group, A = all items KChar ' ' -> toggleMark fieldw [curSel $ itemField fieldw] KChar 'L' -> toggleLineMarks fieldw KChar 'G' -> toggleGroupMarks fieldw KChar 'A' -> toggleAllMarks fieldw -- set marks based on existing state KChar '+' -> setMark Marked fieldw $ allWithState Good KChar '!' -> setMark Marked fieldw $ allWithState Bad KChar '~' -> setMark Marked fieldw $ allWithState Pending KChar 's' -> return $ onFldWidget clrItm markItem $ allWithState Good KChar 'f' -> return $ onFldWidget clrItm markItem $ allWithState Bad KChar 'r' -> if MCtrl `elem` mods then invalidateCache >> return fieldw else return fieldw _ -> return fieldw in case event of EvKey key mods -> handleKey key mods EvMouseDown mcol mrow _button _mods -> do wcoords <- getEventWidgetLocation fieldw mcol mrow case wcoords of Nothing -> return fieldw Just l -> withItemFieldWidth fieldw $ \w -> let rdata = computeLinePosRanges w $ itemField fieldw selly = coordinatesSel oldItm rdata $ loc l in case selly of Nothing -> return fieldw Just (ItemLocNum n) -> selectItemNum n fieldw Just (ItemLocGroup n s) -> selectItemNum n fieldw >>= toggleNamedGroupMarks s -- EvMouseUp col row button -> error $ "MouseUp at " <> show col <> " / " <> show row <> " with " <> show button _ -> return fieldw -- | Useful function for writing custom event handlers for the -- ItemFieldWidget. This wrapper can provide the width of the -- rendered ItemFieldWidget to the custom event handler. withItemFieldWidth :: Ord n => ItemFieldWidget n -> (Int -> EventM n (ItemFieldWidget n)) -> EventM n (ItemFieldWidget n) withItemFieldWidth fieldw op = do v <- lookupViewport $ itemFieldName fieldw case v of Nothing -> return fieldw Just vp -> op $ vp^.vpSize._1 -- ---------------------------------------------------------------------- -- Movement Functions type ItemFieldEventHandler n = ItemFieldWidget n -> EventM n (ItemFieldWidget n) -- | Select specific item by Id selectItemNum :: Int -> ItemFieldEventHandler n selectItemNum n = selectUpdate (update_position $ const . const n) False -- | Select the next or previous item in the item field, moving the -- cursor accordingly. The first argument should be true if the -- state of the newly selected item should be the same as the state of -- the current item. selectNextItem, selectPrevItem :: Bool -> ItemFieldEventHandler n selectNextItem = selectUpdate select_next selectPrevItem = selectUpdate select_prev -- | Move the selection forward or backward by the specified number of -- items in the first argument. Movement will be stopped at the first -- or last item, so specifying a move beyond those boundaries is safe. -- The second argument is a boolean that specifies the extension of -- the current items state across the selection movement (similar to -- the use of the boolean argument for the 'selectNextItem' and -- 'selectPrevItem' functions). selectForwardBy, selectBackwardBy :: Int -> Bool -> ItemFieldEventHandler n selectForwardBy n = selectUpdate (select_forward_n n) selectBackwardBy n = selectUpdate (select_backward_n n) -- | Move the selection to the next line or previous line. The first -- argument specifies the rendering width of the region (viewport) -- that contains the ItemFieldWidget, which allows it to compute the -- line lengths to determine what the target item is for a forward or -- backward line motion. The boolean argument specifies whether the -- intervening and target selection item's states are to be set to the -- current item's state, just as with the 'selectForwardBy' and -- 'selectBackwardBy' functions. selectNextLineItem, selectPrevLineItem :: Int -- ^ the rendering width of the region that contains the ItemFieldWidget -> Bool -- ^ should items between source and destination be set to the source's state? -> ItemFieldEventHandler n -- ^ ItemFieldWidget to operate on and output EventM selectNextLineItem width marking fieldw = let renderData = computeLinePosRanges width $ itemField fieldw in selectUpdate (select_next_line renderData) marking fieldw selectPrevLineItem width marking fieldw = let renderData = computeLinePosRanges width $ itemField fieldw in selectUpdate (select_prev_line renderData) marking fieldw selectUpdate :: FieldUpdateFunc -> Bool -> ItemFieldEventHandler n selectUpdate updfun marking fld = let field = itemField fld (selrange, field') = updfun field firstMarked = head selrange `elem` getMarked field' markState = if firstMarked then Marked else Free field'' = if marking then foldl (changeItemState markState) field' selrange else field' fld' = fld { itemField = field'' } in invalidateCacheEntry (getName fld') >> return fld' -- ---------------------------------------------------------------------- -- Marking Functions toggleMark :: ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n) toggleMark fieldw marks = let newSt8 = if selected `elem` marked then Free else Marked selected = curSel $ itemField fieldw marked = getMarked $ itemField fieldw in invalidateCacheEntry (getName fieldw) >> setMark newSt8 fieldw marks setMark :: ItemState -> ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n) setMark newSt8 fieldw = foldM (setItemState newSt8) fieldw toggleAllMarks :: ItemFieldWidget n -> EventM n (ItemFieldWidget n) toggleAllMarks fieldw = toggleMark fieldw allItems where allItems = [0 .. length (itemst8 $ itemField fieldw) - 1] toggleGroupMarks :: ItemFieldWidget n -> EventM n (ItemFieldWidget n) toggleGroupMarks fieldw = toggleMark fieldw groupItems where groupItems = [fst grng .. snd grng] grng = groupRange selected $ items $ itemField fieldw selected = curSel $ itemField fieldw toggleNamedGroupMarks :: T.Text -> ItemFieldWidget n -> EventM n (ItemFieldWidget n) toggleNamedGroupMarks grpspec fieldw = toggleMark fieldw groupItems where groupNames = T.splitOn (T.singleton '.') grpspec itms = items $ itemField fieldw itemStarts = snd $ mapAccumL (\a i -> let n = numItems i in (a+n, a)) 0 itms itemMatchSpans = map (matchGroupItem groupNames) itms groupRanges = map (\(s,m) -> if m == 0 then [] else [s .. s + m - 1]) $ zip itemStarts itemMatchSpans groupItems = concat groupRanges matchGroupItem :: [T.Text] -> Items -> Int matchGroupItem [] i = numItems i matchGroupItem (g:gs) (ItemGroup n i) = if n == g then matchGroupItem gs i else 0 matchGroupItem _ _ = 0 toggleLineMarks :: Ord n => ItemFieldWidget n -> EventM n (ItemFieldWidget n) toggleLineMarks fieldw = withItemFieldWidth fieldw $ \width -> let renderData = computeLinePosRanges width $ itemField fieldw lens = lineIndices $ renderedLines renderData lnum = fst $ curLine (itemField fieldw) renderData lrange = if lnum >= length lens then error "handleItemFieldEvent index error" else lens !! lnum Just lbeg = lineFirstIndex lrange Just lend = lineLastIndex lrange in if lrange == EmptyLine then return fieldw else toggleMark fieldw [lbeg .. lend] -- ---------------------------------------------------------------------- -- Item retrieval and manipulation -- | Returns the index of the currently selected item in the Widget's field getSelectedItem :: ItemFieldWidget n -> Int getSelectedItem = curSel . itemField -- | Returns the list of the currently marked items in the Widget's field getMarkedItems :: ItemFieldWidget n -> [Int] getMarkedItems = getMarked . itemField -- | Modifies the state of the specified item in the widget to the new value setItemState :: ItemState -> ItemFieldWidget n -> Int -> EventM n (ItemFieldWidget n) setItemState newState widget itemIdx = do invalidateCacheEntry (getName widget) return $ widget { itemField = changeItemState newState (itemField widget) itemIdx } -- | Modifies the state of all currently marked items in the widget. setMarkedItemsState :: ItemState -> ItemFieldWidget n -> EventM n (ItemFieldWidget n) setMarkedItemsState newState widget = do invalidateCacheEntry (getName widget) foldM (setItemState newState) widget $ getMarkedItems widget