itemfield-1.1.0.1: examples/workreport.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
{- This example application uses the ItemField widget to show the status
of a number of asynchronously executing workers as they complete their
work.
-}
module Main where
import Data.List (intercalate)
import Data.Monoid
import Data.Default
import Data.String (IsString)
import Brick
import Brick.Widgets.Center (hCenter)
import Graphics.Vty (Event(..), Key(..), mkVty, outputIface, supportsMode, Mode(..), setMode, Vty)
import Graphics.Vty.Attributes
import TextUI.ItemField
import Brick.Widgets.Border
import Lens.Micro ((^.), Lens', (.~), (&))
import Lens.Micro.TH (makeLenses)
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import System.Random
data WorkEvent = WorkerFinished Int ItemState
data WorkerTeams n = WorkerTeams { _workers :: ItemFieldWidget n
, _reqChannel :: Chan WorkEvent
}
makeLenses ''WorkerTeams
setupFactory :: n -> Chan WorkEvent -> WorkerTeams n
setupFactory n =
let teams = [ ItemGroup "Team 1" (Items 28)
, ItemGroup "Team 2" (Items 238)
, ItemGroup "Team 3" $ ItemGroup "Group 1" $ Items 93
, ItemGroup "Team 3" $ ItemGroup "Group 2" $ Items 127
, ItemGroup "Team 3" $ ItemGroup "Group 3" $ Items 56
, ItemGroup "Team 3" $ Items 596
, ItemGroup "Team 4" $ Items 77
, ItemGroup "Team 5" $ Items 0
, ItemGroup "Team 6" $ Items 3
]
-- teams = [] -- alternative: no workers, not very interesting
in WorkerTeams (ItemFieldWidget n $ newItemField teams Nothing)
workerstate :: IsString s => ItemState -> s
workerstate s = case s of
Good -> "done"
Bad -> "error"
CaVa -> "delayed"
_ -> ""
-- KWQ: add a mapper that will map through and provide index, state, and [groups]
-- KWQ: add a mapper that will map through groups, with sub-mapping for index, state
showWorkers :: WorkerTeams n -> String
showWorkers teams =
let ws = itemField $ teams^.workers
st8s = itemst8 ws
numSt8 st8 = length . filter (st8 ==)
showNum = show . flip numSt8 st8s
summary s = showNum s <> " " <> workerstate s
in intercalate ", " [ show (length st8s) <> " workers"
, summary Good, summary CaVa, summary Bad
]
data WorkerTeamsName = WorkerTeamsName deriving (Eq, Ord, Show)
drawWorkers :: (Show n, Ord n) => WorkerTeams n -> [Widget n]
drawWorkers teams =
[ vBox [ hCenter $ str "Workers"
, itemFieldWidget $ teams^.workers
, hBorder
, str " Movement: arrows, or '<' and '>' to jump."
, str "Toggle item selection: space = single item, L = line, G = group, A = all"
, str " right or left arrow with shift extends selection"
, str " !, ~, or + selects all corresponding items"
, str " s, f select only successes or failures"
, str " Misc: Q/q = quit, r = run workers"
, str ""
, str "When run, workers will asynchronously \"do some work\" and then"
, str "set their state to good or bad."
]
]
workEvent :: Ord n => WorkerTeams n -> BrickEvent n WorkEvent -> EventM n (Next (WorkerTeams n))
workEvent s (VtyEvent ve) = workVtyEvt ve
where
workVtyEvt (EvResize _ _) = continue s
workVtyEvt (EvKey (KChar 'r') []) = runWork s
-- workVtyEvt e@(EvKey (KChar 'r') []) = continue =<< handleEventLensed s workers (runWork (s^. e
-- workVtyEvt e@(EvKey (KChar 'l') []) = continue =<< handleEventLensed s shelves (setBooks CaVa) e
-- workVtyEvt e@(EvKey (KChar 'm') []) = continue =<< handleEventLensed s shelves (setBooks Bad) e
workVtyEvt (EvKey (KChar 'Q') []) = halt s
workVtyEvt (EvKey (KChar 'q') []) = halt s
workVtyEvt _ = continue =<< handleEventLensed s workers handleItemFieldEvent ve
workEvent s (AppEvent e@(WorkerFinished wnum result)) =
continue =<< handleEventL s workers (workDone wnum result) e
workEvent s _ = continue s
handleEventL :: a
-- ^ The state value.
-> Lens' a b
-- ^ The lens to use to extract and store the target
-- of the event.
-> (e -> b -> EventM n b)
-- ^ The event handler.
-> e
-- ^ The event to handle.
-> EventM n a
handleEventL v target handleEvent ev = do
newB <- handleEvent ev (v^.target)
return $ v & target .~ newB
runWork :: WorkerTeams n -> EventM n (Next (WorkerTeams n))
runWork wt =
let chan = wt^.reqChannel
marked = getMarkedItems $ wt^.workers
startwork c i = forkIO $ doWork c i
in liftIO (mapM_ (startwork chan) marked) >> continue wt
doWork :: Chan WorkEvent -> Int -> IO ()
doWork reportChan myId =
do r <- randomRIO (100000,3000000)
threadDelay r
s <- ([Good, Bad, CaVa] !!) <$> randomRIO (0,2)
writeChan reportChan $ WorkerFinished myId s
when (s == CaVa) $ doWork reportChan myId
-- KWQ: workers can report their total time taken and result, which can be displayed in a separate widget
-- KWQ: with brick viewport scrolling, is itemMoreMessageAttr and associated even used?
-- KWQ: vi/emacs style movement? means top level entrypoints for those event processors (and move their utilities into hidding internal operations?)
workDone :: Int -> ItemState -> t -> ItemFieldWidget n -> EventM n (ItemFieldWidget n)
workDone workerNum toState _ fieldw =
return $ setItemState toState fieldw workerNum
workAttrs :: AttrMap
workAttrs =
applyAttrMappings [ (itemFieldAttr, bg brightBlack)
, (itemFreeAttr, defAttr `withStyle` dim)
, (itemBadAttr, brightYellow `on` red `withStyle` bold)
, (itemHeaderAttr, bg blue `withStyle` underline)
] $
applyAttrMappings itemDefaultAttrs $
setDefault (white `on` black) def
enableMouse :: Graphics.Vty.Vty -> IO ()
enableMouse v = let output = outputIface v
in when (supportsMode output Mouse) $ setMode output Mouse True
main :: IO ()
main = do
chan <- newChan
let allworkers = setupFactory WorkerTeamsName chan
app = App { appDraw = drawWorkers
, appHandleEvent = workEvent
, appStartEvent = return
, appAttrMap = const workAttrs
, appChooseCursor = showFirstCursor
}
vty = do v <- mkVty def
enableMouse v
return v
mapM_ (forkIO . doWork chan) [8 .. 12] -- initial sample work
putStrLn . ("Final results: " <>) . showWorkers =<< customMain vty (Just chan) app allworkers