itemfield-1.2.3.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.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 TextUI.ItemField.BrickHelper (BChan, newBChan, writeBChan)
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) 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 <- newBChan 100
  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