taskell-1.8.2.0: src/App.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections #-}

module App
    ( go
    ) where

import ClassyPrelude

import Control.Concurrent (forkIO, threadDelay)

import Control.Lens ((^.))

import Data.Time.Zones (TZ)

import Brick
import Brick.BChan               (BChan, newBChan, writeBChan)
import Graphics.Vty              (Mode (BracketedPaste), defaultConfig, displayBounds, mkVty,
                                  outputIface, setMode, supportsMode)
import Graphics.Vty.Input.Events (Event (..))

import qualified Control.FoldDebounce as Debounce

import Data.Taskell.Lists      (Lists)
import Events.Actions          (ActionSets, event, generateActions)
import Events.State            (continue, countCurrent, setHeight, setTime)
import Events.State.Types      (State, current, io, lists, mode, path, searchTerm, timeZone)
import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..))
import IO.Config               (Config, debugging, generateAttrMap, getBindings, layout)
import IO.Taskell              (writeData)
import Types                   (ListIndex (..), TaskIndex (..))
import UI.Draw                 (chooseCursor, draw)
import UI.Types                (ResourceName (..))

type DebouncedMessage = (Lists, FilePath, TZ)

type DebouncedWrite = DebouncedMessage -> IO ()

type Trigger = Debounce.Trigger DebouncedMessage DebouncedMessage

-- tick
data TaskellEvent =
    Tick

oneSecond :: Int
oneSecond = 1000000

frequency :: Int
frequency = 60 * oneSecond

timer :: BChan TaskellEvent -> IO ()
timer chan =
    void . forkIO . forever $ do
        writeBChan chan Tick
        threadDelay frequency

-- store
store :: Config -> DebouncedMessage -> IO ()
store config (ls, pth, tz) = writeData tz 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, state ^. timeZone)
            Brick.continue $ Events.State.continue state
        Nothing -> Brick.continue state

-- debouncing
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, initial ^. timeZone)
            }
            Debounce.def
    let send = Debounce.send trigger
    pure (send, trigger)

-- cache clearing
clearCache :: State -> EventM ResourceName ()
clearCache state = do
    let (ListIndex li, TaskIndex 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 . (, TaskIndex (-1)) . ListIndex) range

clearList :: State -> EventM ResourceName ()
clearList state = do
    let (ListIndex list, _) = state ^. current
    let count = countCurrent state
    let range = [0 .. (count - 1)]
    invalidateCacheEntry $ RNList list
    traverse_ (invalidateCacheEntry . RNTask . (,) (ListIndex list) . TaskIndex) range

clearDue :: State -> EventM ResourceName ()
clearDue state =
    case state ^. mode of
        Modal (Due dues _) -> do
            let range = [0 .. (length dues + 1)]
            traverse_ (invalidateCacheEntry . RNDue) range
        _ -> pure ()

-- event handling
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 Due {}) -> clearDue state *> next send 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 <$> (liftIO . displayBounds =<< outputIface <$> getVtyHandle)

handleEvent ::
       (DebouncedWrite, Trigger)
    -> ActionSets
    -> State
    -> BrickEvent ResourceName TaskellEvent
    -> EventM ResourceName (Next State)
handleEvent _ _ state (AppEvent Tick) = do
    t <- liftIO getCurrentTime
    Brick.continue $ setTime t 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

-- | Runs when the app starts
--   Adds paste support
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)

-- | Sets up Brick
go :: Config -> State -> IO ()
go config initial = do
    attrMap' <- const <$> generateAttrMap
    -- setup debouncing
    db <- debounce config initial
    -- get bindings
    bindings <- getBindings
    -- setup timer channel
    timerChan <- newBChan 1
    timer timerChan
    -- create app
    let app =
            App
            { appDraw = draw (layout config) bindings (debugging config)
            , appChooseCursor = chooseCursor
            , appHandleEvent = handleEvent db (generateActions bindings)
            , appStartEvent = appStart
            , appAttrMap = attrMap'
            }
    -- start
    let builder = mkVty defaultConfig
    initialVty <- builder
    void $ customMain initialVty builder (Just timerChan) app initial