module TextUI.ItemField
( module TextUI.ItemField.Types
, ItemFieldWidget(..)
, itemFieldWidget
#ifdef TEST
, itemFieldRender
#endif
, handleItemFieldEvent
, withItemFieldWidth
, setItemState
, getSelectedItem
, getMarkedItems
, setMarkedItemsState
, module TextUI.ItemField.Attrs
)
where
import Brick.AttrMap
import Brick.Main (lookupViewport)
import Brick.Types
import Brick.Widgets.Core
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
data ItemFieldWidget n =
ItemFieldWidget { itemFieldName :: n
, itemField :: ItemField
}
instance Show (ItemFieldWidget n) where
show = show . itemField
instance Named (ItemFieldWidget n) n where
getName = itemFieldName
itemFieldWidget :: (Show n, Ord n) => ItemFieldWidget n -> Widget n
itemFieldWidget field =
let i = reportExtent (getName field) $
viewport (getName field) Vertical $
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)] []
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
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
KDown -> withItemFieldWidth fieldw $ \w -> selectNextLineItem w False fieldw
KUp -> withItemFieldWidth fieldw $ \w -> selectPrevLineItem w False fieldw
KChar ' ' -> toggleMark fieldw [curSel $ itemField fieldw]
KChar 'L' -> toggleLineMarks fieldw
KChar 'G' -> toggleGroupMarks fieldw
KChar 'A' -> toggleAllMarks fieldw
KChar '+' -> setMark Marked fieldw $ allWithState Good
KChar '!' -> setMark Marked fieldw $ allWithState Bad
KChar '~' -> setMark Marked fieldw $ allWithState CaVa
KChar 's' -> return $ onFldWidget clrItm markItem $ allWithState Good
KChar 'f' -> return $ onFldWidget clrItm markItem $ allWithState Bad
_ -> 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
_ -> return fieldw
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
type ItemFieldEventHandler n = ItemFieldWidget n -> EventM n (ItemFieldWidget n)
selectItemNum :: Int -> ItemFieldEventHandler n
selectItemNum n = selectUpdate (update_position $ const . const n) False
selectNextItem, selectPrevItem :: Bool -> ItemFieldEventHandler n
selectNextItem = selectUpdate select_next
selectPrevItem = selectUpdate select_prev
selectForwardBy, selectBackwardBy :: Int -> Bool -> ItemFieldEventHandler n
selectForwardBy n = selectUpdate (select_forward_n n)
selectBackwardBy n = selectUpdate (select_backward_n n)
selectNextLineItem, selectPrevLineItem
:: Int
-> Bool
-> ItemFieldEventHandler n
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 return fld'
toggleMark :: ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n)
toggleMark fieldw =
let newSt8 = if selected `elem` marked then Free else Marked
selected = curSel $ itemField fieldw
marked = getMarked $ itemField fieldw
in setMark newSt8 fieldw
setMark :: ItemState -> ItemFieldWidget n -> [Int] -> EventM n (ItemFieldWidget n)
setMark newSt8 fieldw = return . foldl (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]
getSelectedItem :: ItemFieldWidget n -> Int
getSelectedItem = curSel . itemField
getMarkedItems :: ItemFieldWidget n -> [Int]
getMarkedItems = getMarked . itemField
setItemState :: ItemState -> ItemFieldWidget n -> Int -> ItemFieldWidget n
setItemState newState widget itemIdx =
widget { itemField = changeItemState newState (itemField widget) itemIdx }
setMarkedItemsState :: ItemState -> ItemFieldWidget n -> ItemFieldWidget n
setMarkedItemsState newState widget =
foldl (setItemState newState) widget $ getMarkedItems widget