{-# 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 ] -- 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 :: 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 -- 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 = 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