itemfield-1.2.4.0: 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 Prelude hiding (length)
import Compat
import Data.List (intercalate)
import Data.Monoid
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 TextUI.ItemField.BrickHelper (BChan, newBChan, writeBChan, defaultConfig)
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 :: BChan WorkEvent
}
makeLenses ''WorkerTeams
setupFactory :: n -> BChan 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
]
in WorkerTeams (ItemFieldWidget n $ newItemField teams Nothing)
workerstate :: IsString s => ItemState -> s
workerstate s = case s of
Good -> "done"
Bad -> "error"
Pending -> "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 Pending, 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 Pending) 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 :: BChan WorkEvent -> Int -> IO ()
doWork reportChan myId =
do r <- randomRIO (100000,3000000)
threadDelay r
s <- ([Good, Bad, Pending] !!) <$> randomRIO (0,2)
writeBChan reportChan $ WorkerFinished myId s
when (s == Pending) $ doWork reportChan myId
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) $ attrMap defAttr []
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 <- newBChan 100
let allworkers = setupFactory WorkerTeamsName chan
app = App { appDraw = drawWorkers
, appHandleEvent = workEvent
, appStartEvent = return
, appAttrMap = const workAttrs
, appChooseCursor = showFirstCursor
}
vty = do v <- mkVty defaultConfig
enableMouse v
return v
mapM_ (forkIO . doWork chan) [8 .. 12] -- initial sample work
putStrLn . ("Final results: " <>) . showWorkers =<< customMain vty (Just chan) app allworkers