{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
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, count)
import qualified Data.Taskell.Task as T (Task, contains, countCompleteSubtasks, countSubtasks,
description, due, hasSubtasks, name)
import Events.State (normalise)
import Events.State.Types (Pointer, State, current, height, lists, mode, path,
searchTerm)
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, getText, textField, widgetFromMaybe)
import UI.Modal (showModal)
import UI.Theme
import UI.Types (ListIndex (..), ResourceName (..), TaskIndex (..))
data DrawState = DrawState
{ dsLists :: Lists
, dsMode :: Mode
, dsLayout :: Config
, dsPath :: FilePath
, dsToday :: Day
, dsCurrent :: Pointer
, dsField :: Maybe Field
, dsEditingTitle :: Bool
, dsSearchTerm :: Maybe Field
}
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
renderTask :: Int -> Int -> T.Task -> ReaderDrawState (Widget ResourceName)
renderTask listIndex taskIndex task = do
searchT <- asks dsSearchTerm
case searchT of
Nothing -> renderTask' listIndex taskIndex task
Just term ->
if T.contains (getText term) task
then renderTask' listIndex taskIndex task
else pure emptyWidget
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 <- asks dsMode
term <- asks dsSearchTerm
case term of
Just searchField -> do
colPad <- columnPadding . dsLayout <$> ask
let attr =
withAttr $
case m of
Search -> taskCurrentAttr
_ -> taskAttr
let widget = attr . padLeftRight colPad $ txt "/" <+> field searchField
pure $ mainWidget <=> widget
_ -> pure mainWidget
getPosition :: ReaderDrawState Text
getPosition = do
(col, pos) <- asks dsCurrent
len <- count col <$> asks dsLists
let posNorm =
if len > 0
then pos + 1
else 0
pure $ tshow posNorm <> "/" <> tshow len
modeToText :: Maybe Field -> Mode -> Text
modeToText fld =
\case
Normal ->
case fld of
Nothing -> "NORMAL"
Just _ -> "NORMAL + SEARCH"
Insert {} -> "INSERT"
Modal Help -> "HELP"
Modal MoveTo -> "MOVE"
Modal Detail {} -> "DETAIL"
Search {} -> "SEARCH"
_ -> ""
getMode :: ReaderDrawState Text
getMode = modeToText <$> asks dsSearchTerm <*> asks dsMode
renderStatusBar :: ReaderDrawState (Widget ResourceName)
renderStatusBar = do
topPath <- pack <$> asks dsPath
colPad <- columnPadding <$> asks dsLayout
posTxt <- getPosition
modeTxt <- getMode
let titl = padLeftRight colPad $ txt topPath
let pos = padRight (Pad colPad) $ txt posTxt
let md = txt modeTxt
let bar = padRight Max (titl <+> md) <+> pos
pure . padTop (Pad 1) $ withAttr statusBarAttr bar
main :: ReaderDrawState (Widget ResourceName)
main = do
ls <- dsLists <$> ask
listWidgets <- toList <$> sequence (renderList `mapWithIndex` ls)
let mainWidget = viewport RNLists Horizontal . padTopBottom 1 $ hBox listWidgets
statusBar <- renderStatusBar
renderSearch (mainWidget <=> statusBar)
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
drawR :: Int -> State -> Bindings -> ReaderDrawState [Widget ResourceName]
drawR ht normalisedState bindings = do
modal <- showModal ht bindings normalisedState <$> asks dsToday
mn <- main
pure [modal, mn]
draw :: Config -> Bindings -> Day -> State -> [Widget ResourceName]
draw layout bindings today state = runReader (drawR ht normalisedState bindings) drawState
where
normalisedState = normalise state
stateMode = state ^. mode
ht = state ^. height
drawState =
DrawState
{ dsLists = normalisedState ^. lists
, dsMode = stateMode
, dsLayout = layout
, dsPath = normalisedState ^. path
, dsToday = today
, dsField = getField stateMode
, dsCurrent = normalisedState ^. current
, dsEditingTitle = editingTitle stateMode
, dsSearchTerm = normalisedState ^. searchTerm
}
chooseCursor :: State -> [CursorLocation ResourceName] -> Maybe (CursorLocation ResourceName)
chooseCursor state =
case normalise state ^. mode of
Insert {} -> showCursorNamed RNCursor
Search -> showCursorNamed RNCursor
Modal (Detail _ (DetailInsert _)) -> showCursorNamed RNCursor
_ -> neverShowCursor state