{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module UI.Draw
( draw
, chooseCursor
) where
import ClassyPrelude
import Control.Lens ((^.))
import Control.Monad.Reader (runReader)
import Data.Char (chr, ord)
import Data.Sequence (mapWithIndex)
import Brick
import Data.Taskell.Date (Day, dayToText, deadline)
import Data.Taskell.List (List, tasks, title)
import Data.Taskell.Lists (Lists)
import qualified Data.Taskell.Task as T (Task, countCompleteSubtasks, countSubtasks,
description, due, hasSubtasks, name)
import Events.State (normalise)
import Events.State.Types (Pointer, State, current, lists, mode)
import Events.State.Types.Mode (DetailMode (..), InsertType (..), ModalType (..),
Mode (..))
import IO.Config.Layout (Config, columnPadding, columnWidth, descriptionIndicator)
import IO.Keyboard.Types (Bindings)
import UI.Field (Field, field, textField, widgetFromMaybe)
import UI.Modal (showModal)
import UI.Theme
import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..))
data DrawState = DrawState
{ dsLists :: Lists
, dsMode :: Mode
, dsLayout :: Config
, dsToday :: Day
, dsCurrent :: Pointer
, dsField :: Maybe Field
, dsEditingTitle :: Bool
}
type ReaderDrawState = ReaderT DrawState Identity
renderDate :: Maybe Day -> ReaderDrawState (Maybe (Widget ResourceName))
renderDate dueDay = do
today <- dsToday <$> ask
let attr = withAttr . dlToAttr . deadline today <$> dueDay
widget = txt . dayToText today <$> dueDay
pure $ attr <*> widget
renderSubtaskCount :: T.Task -> Widget ResourceName
renderSubtaskCount task =
txt $ concat ["[", tshow $ T.countCompleteSubtasks task, "/", tshow $ T.countSubtasks task, "]"]
indicators :: T.Task -> ReaderDrawState (Widget ResourceName)
indicators task = do
dateWidget <- renderDate (task ^. T.due)
descIndicator <- descriptionIndicator . dsLayout <$> ask
pure . hBox $
padRight (Pad 1) <$>
catMaybes
[ const (txt descIndicator) <$> task ^. T.description
, bool Nothing (Just (renderSubtaskCount task)) (T.hasSubtasks task)
, dateWidget
]
renderTask :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName)
renderTask listIndex taskIndex task = do
eTitle <- dsEditingTitle <$> ask
selected <- (== (listIndex, taskIndex)) . dsCurrent <$> ask
taskField <- dsField <$> ask
after <- indicators task
let text = task ^. T.name
name = RNTask (ListIndex listIndex, TaskIndex taskIndex)
widget = textField text
widget' = widgetFromMaybe widget taskField
pure $
cached name .
(if selected && not eTitle
then visible
else id) .
padBottom (Pad 1) .
(<=> withAttr disabledAttr after) .
withAttr
(if selected
then taskCurrentAttr
else taskAttr) $
if selected && not eTitle
then widget'
else widget
columnPrefix :: Int -> Int -> ReaderDrawState Text
columnPrefix selectedList i = do
m <- dsMode <$> ask
if moveTo m
then do
let col = chr (i + ord 'a')
pure $
if i /= selectedList && i >= 0 && i <= 26
then singleton col <> ". "
else ""
else do
let col = i + 1
pure $
if col >= 1 && col <= 9
then tshow col <> ". "
else ""
renderTitle :: Int -> List -> ReaderDrawState (Widget ResourceName)
renderTitle listIndex list = do
(selectedList, selectedTask) <- dsCurrent <$> ask
editing <- (selectedList == listIndex &&) . dsEditingTitle <$> ask
titleField <- dsField <$> ask
col <- txt <$> columnPrefix selectedList listIndex
let text = list ^. title
attr =
if selectedList == listIndex
then titleCurrentAttr
else titleAttr
widget = textField text
widget' = widgetFromMaybe widget titleField
title' =
padBottom (Pad 1) . withAttr attr . (col <+>) $
if editing
then widget'
else widget
pure $
if editing || selectedList /= listIndex || selectedTask == 0
then visible title'
else title'
renderList :: Int -> List -> ReaderDrawState (Widget ResourceName)
renderList listIndex list = do
layout <- dsLayout <$> ask
eTitle <- dsEditingTitle <$> ask
titleWidget <- renderTitle listIndex list
(currentList, _) <- dsCurrent <$> ask
taskWidgets <- sequence $ renderTask listIndex `mapWithIndex` (list ^. tasks)
let widget =
(if not eTitle
then cached (RNList listIndex)
else id) .
padLeftRight (columnPadding layout) .
hLimit (columnWidth layout) .
viewport (RNList listIndex) Vertical . vBox . (titleWidget :) $
toList taskWidgets
pure $
if currentList == listIndex
then visible widget
else widget
renderSearch :: Widget ResourceName -> ReaderDrawState (Widget ResourceName)
renderSearch mainWidget = do
m <- dsMode <$> ask
case m of
Search editing searchField -> do
colPad <- columnPadding . dsLayout <$> ask
let attr =
withAttr $
if editing
then taskCurrentAttr
else taskAttr
let widget = attr . padTopBottom 1 . padLeftRight colPad $ txt "/" <+> field searchField
pure $ mainWidget <=> widget
_ -> pure mainWidget
main :: ReaderDrawState (Widget ResourceName)
main = do
ls <- dsLists <$> ask
listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls)
let mainWidget = viewport RNLists Horizontal . padTopBottom 1 $ hBox listWidgets
renderSearch mainWidget
getField :: Mode -> Maybe Field
getField (Insert _ _ f) = Just f
getField _ = Nothing
editingTitle :: Mode -> Bool
editingTitle (Insert IList _ _) = True
editingTitle _ = False
moveTo :: Mode -> Bool
moveTo (Modal MoveTo) = True
moveTo _ = False
draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName]
draw layout bindings today state =
showModal
bindings
normalisedState
today
[ runReader
main
DrawState
{ dsLists = normalisedState ^. lists
, dsMode = stateMode
, dsLayout = layout
, dsToday = today
, dsField = getField stateMode
, dsCurrent = normalisedState ^. current
, dsEditingTitle = editingTitle stateMode
}
]
where
normalisedState = normalise state
stateMode = state ^. mode
chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName)
chooseCursor state =
case normalise state ^. mode of
Insert {} -> showCursorNamed RNCursor
Search True _ -> showCursorNamed RNCursor
Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor
_ -> neverShowCursor state