{-# 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.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" 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 :: Chan WorkEvent -> Int -> IO () doWork reportChan myId = do r <- randomRIO (100000,3000000) threadDelay r s <- ([Good, Bad, Pending] !!) <$> randomRIO (0,2) writeChan reportChan $ WorkerFinished myId s when (s == Pending) $ 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