{-# LANGUAGE NoImplicitPrelude #-}
module App
( go
) where
import ClassyPrelude
import Control.Lens ((^.))
import Brick
import Graphics.Vty (Mode (BracketedPaste), displayBounds, outputIface, setMode,
supportsMode)
import Graphics.Vty.Input.Events (Event (..))
import qualified Control.FoldDebounce as Debounce
import Data.Taskell.Date (currentDay)
import Data.Taskell.Lists (Lists)
import Events.Actions (ActionSets, event, generateActions)
import Events.State (continue, countCurrent, setHeight)
import Events.State.Types (State, current, io, lists, mode, path, searchTerm)
import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..))
import IO.Config (Config, generateAttrMap, getBindings, layout)
import IO.Taskell (writeData)
import UI.Draw (chooseCursor, draw)
import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..))
type DebouncedMessage = (Lists, FilePath)
type DebouncedWrite = DebouncedMessage -> IO ()
type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage
store :: Config -> DebouncedMessage -> IO ()
store config (ls, pth) = writeData config ls pth
next :: DebouncedWrite -> State -> EventM ResourceName (Next State)
next send state =
case state ^. io of
Just ls -> do
invalidateCache
liftIO $ send (ls, state ^. path)
Brick.continue $ Events.State.continue state
Nothing -> Brick.continue state
debounce :: Config -> State -> IO (DebouncedWrite, Trigger)
debounce config initial = do
trigger <-
Debounce.new
Debounce.Args
{ Debounce.cb = store config
, Debounce.fold = flip const
, Debounce.init = (initial ^. lists, initial ^. path)
}
Debounce.def
let send = Debounce.send trigger
pure (send, trigger)
clearCache :: State -> EventM ResourceName ()
clearCache state = do
let (li, ti) = state ^. current
invalidateCacheEntry (RNList li)
invalidateCacheEntry (RNTask (ListIndex li, TaskIndex ti))
clearAllTitles :: State -> EventM ResourceName ()
clearAllTitles state = do
let count = length (state ^. lists)
let range = [0 .. (count - 1)]
traverse_ (invalidateCacheEntry . RNList) range
traverse_ (invalidateCacheEntry . RNTask . flip (,) (TaskIndex (-1)) . ListIndex) range
clearList :: State -> EventM ResourceName ()
clearList state = do
let (list, _) = state ^. current
let count = countCurrent state
let range = [0 .. (count - 1)]
invalidateCacheEntry $ RNList list
traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range
handleVtyEvent ::
(DebouncedWrite, Trigger) -> ActionSets -> State -> Event -> EventM ResourceName (Next State)
handleVtyEvent (send, trigger) actions previousState e = do
let state = event actions e previousState
when (previousState ^. searchTerm /= state ^. searchTerm) invalidateCache
case previousState ^. mode of
(Modal MoveTo) -> clearAllTitles previousState
(Insert ITask ICreate _) -> clearList previousState
_ -> pure ()
case state ^. mode of
Shutdown -> liftIO (Debounce.close trigger) *> Brick.halt state
(Modal MoveTo) -> clearAllTitles state *> next send state
(Insert ITask ICreate _) -> clearList state *> next send state
_ -> clearCache previousState *> clearCache state *> next send state
getHeight :: EventM ResourceName Int
getHeight = snd <$> (displayBounds =<< outputIface <$> getVtyHandle)
handleEvent ::
(DebouncedWrite, Trigger)
-> ActionSets
-> State
-> BrickEvent ResourceName e
-> EventM ResourceName (Next State)
handleEvent _ _ state (VtyEvent (EvResize _ _)) = do
invalidateCache
h <- getHeight
Brick.continue (setHeight h state)
handleEvent db actions state (VtyEvent ev) = handleVtyEvent db actions state ev
handleEvent _ _ state _ = Brick.continue state
appStart :: State -> EventM ResourceName State
appStart state = do
output <- outputIface <$> getVtyHandle
when (supportsMode output BracketedPaste) . liftIO $ setMode output BracketedPaste True
h <- getHeight
pure (setHeight h state)
go :: Config -> State -> IO ()
go config initial = do
attrMap' <- const <$> generateAttrMap
today <- currentDay
db <- debounce config initial
bindings <- getBindings
let app =
App
{ appDraw = draw (layout config) bindings today
, appChooseCursor = chooseCursor
, appHandleEvent = handleEvent db (generateActions bindings)
, appStartEvent = appStart
, appAttrMap = attrMap'
}
void (defaultMain app initial)