From c72ca628f98f9f1fff3f6fb2767523abe5f51360 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 18 Sep 2018 19:41:12 +0000 Subject: [PATCH] Add back basic UI --- app/Main.hs | 39 ++------ package.yaml | 6 +- src/TaskMachine/LTask.hs | 6 +- src/TaskMachine/Options.hs | 28 ++++++ src/TaskMachine/Task.hs | 46 ++++----- src/TaskMachine/UI.hs | 65 ++++++++++++ src/TaskMachine/UI/NewTask.hs | 8 ++ src/TaskMachine/UI/Popup.hs | 34 +++++++ src/TaskMachine/UI/Task.hs | 86 ++++++++++++++++ src/TaskMachine/UI/TaskList.hs | 178 +++++++++++++++++++++++++++++++++ src/TaskMachine/UI/TopBar.hs | 6 ++ src/TaskMachine/UI/Types.hs | 176 ++++++++++++++++++++++++++++++++ 12 files changed, 616 insertions(+), 62 deletions(-) create mode 100644 src/TaskMachine/Options.hs create mode 100644 src/TaskMachine/UI.hs create mode 100644 src/TaskMachine/UI/NewTask.hs create mode 100644 src/TaskMachine/UI/Popup.hs create mode 100644 src/TaskMachine/UI/Task.hs create mode 100644 src/TaskMachine/UI/TaskList.hs create mode 100644 src/TaskMachine/UI/TopBar.hs create mode 100644 src/TaskMachine/UI/Types.hs diff --git a/app/Main.hs b/app/Main.hs index 2a00cca..2f4e709 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,42 +1,15 @@ module Main where -{- -import Control.Applicative import Control.Monad -import qualified Brick as B -import qualified Options.Applicative as O +import qualified Brick as B -import TaskMachine.LTask +import TaskMachine.Options import TaskMachine.UI -import TaskMachine.UI.Types - -newtype Options = Options - { oTodofile :: FilePath - } deriving (Show) - -opts :: O.Parser Options -opts = pure Options - <*> todofile - where - todofile = O.strArgument - ( O.help "The file containing all your tasks" - <> O.metavar "TODOFILE" - ) - -optsInfo :: O.ParserInfo Options -optsInfo = O.info (opts <**> O.helper) O.fullDesc - -- <> O.progDesc "program description" - -- <> O.header "help header" +import TaskMachine.UI.TaskList main :: IO() main = do - o <- O.execParser optsInfo - result <- loadLTasks (oTodofile o) - case result of - Left parseError -> putStrLn parseError - Right tasks -> void $ B.defaultMain (myApp defaultTheme) (startUIState tasks) --} - -main :: IO () -main = putStrLn "Hello world again" + o <- parseOptions + state <- loadTasks (startUIState o) + void $ B.defaultMain myApp state diff --git a/package.yaml b/package.yaml index a58512b..41e392b 100644 --- a/package.yaml +++ b/package.yaml @@ -24,11 +24,11 @@ dependencies: #- ConfigFile #- aeson #- async - #- brick +- brick #- bytestring - containers - megaparsec - #- optparse-applicative +- optparse-applicative #- sqlite-simple #- stm #- text @@ -38,7 +38,7 @@ dependencies: #- unix #- unordered-containers - vector - #- vty +- vty # tests - hspec - QuickCheck diff --git a/src/TaskMachine/LTask.hs b/src/TaskMachine/LTask.hs index 44d14c1..076c043 100644 --- a/src/TaskMachine/LTask.hs +++ b/src/TaskMachine/LTask.hs @@ -55,9 +55,9 @@ loadLTasks file = do content <- readFile file case parse pTasks file content of Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList - Left parseError -> pure $ Left $ show parseError + Left parseError -> pure $ Left $ parseErrorPretty parseError -saveLTasks :: V.Vector LTask -> FilePath -> IO () -saveLTasks ltasks file = do +saveLTasks :: FilePath -> V.Vector LTask -> IO () +saveLTasks file ltasks = do let text = formatTasks $ toTasks $ V.toList ltasks writeFile file text diff --git a/src/TaskMachine/Options.hs b/src/TaskMachine/Options.hs new file mode 100644 index 0000000..eea1a72 --- /dev/null +++ b/src/TaskMachine/Options.hs @@ -0,0 +1,28 @@ +module TaskMachine.Options + ( Options(..) + , parseOptions + ) where + +import Control.Applicative + +import qualified Options.Applicative as O + +newtype Options = Options + { oTodofile :: FilePath + } deriving (Show) + +opts :: O.Parser Options +opts = Options <$> todofile + where + todofile = O.strArgument + ( O.help "The file containing all your tasks" + <> O.metavar "TODOFILE" + ) + +optsInfo :: O.ParserInfo Options +optsInfo = O.info (opts <**> O.helper) O.fullDesc + -- <> O.progDesc "program description" + -- <> O.header "help header" + +parseOptions :: IO Options +parseOptions = O.execParser optsInfo diff --git a/src/TaskMachine/Task.hs b/src/TaskMachine/Task.hs index 6052373..a8a726c 100644 --- a/src/TaskMachine/Task.hs +++ b/src/TaskMachine/Task.hs @@ -24,8 +24,8 @@ module TaskMachine.Task , formatTask , formatTasks , formatDate - , formatDueDate - , formatCreationDate + , formatDue + , formatCreated , formatCompletion , formatPriority , formatDescription @@ -42,8 +42,8 @@ module TaskMachine.Task , pPriorityChar , pPriority , pDate - , pDueDate - , pCreationDate + , pDue + , pCreated , pDescription , pSnippet ) where @@ -61,7 +61,7 @@ import Text.Megaparsec.Char -- | A single task data Task = Task - { taskCompleted :: Completion + { taskCompletion :: Completion , taskPriority :: Maybe Priority , taskDue :: Maybe Day , taskCreated :: Maybe Day @@ -77,10 +77,10 @@ data Task = Task -- In that case, converting the task to a string and back yields a different result. formatTask :: Task -> String formatTask t - = formatCompletion (taskCompleted t) ++ " " + = formatCompletion (taskCompletion t) ++ " " ++ maybeWithSpace formatPriority (taskPriority t) - ++ maybeWithSpace formatDueDate (taskDue t) - ++ maybeWithSpace formatCreationDate (taskCreated t) + ++ maybeWithSpace formatDue(taskDue t) + ++ maybeWithSpace formatCreated (taskCreated t) ++ formatDescription (taskDescription t) where maybeWithSpace :: (a -> String) -> Maybe a -> String @@ -99,17 +99,17 @@ formatTasks = concatMap ((++"\n") . formatTask) formatDate :: Day -> String formatDate = show --- | Convert a 'Day' into the due date string representation, which can be parsed by 'pDueDate'. +-- | Convert a 'Day' into the due date string representation, which can be parsed by 'pDue'. -- -- Example: @"d2018-09-08"@ -formatDueDate :: Day -> String -formatDueDate d = 'd' : formatDate d +formatDue :: Day -> String +formatDue d = 'd' : formatDate d --- | Convert a 'Day into the creation date string representation, which can be parsed by 'pCreationDate'. +-- | Convert a 'Day into the creation date string representation, which can be parsed by 'pCreation. -- -- Example: @"c2018-09-08"@ -formatCreationDate :: Day -> String -formatCreationDate d = 'c' : formatDate d +formatCreated :: Day -> String +formatCreated d = 'c' : formatDate d {- Completion -} @@ -213,13 +213,13 @@ pDate = label "date" $ fromGregorian int :: Parser Int int = read <$> count 2 digitChar --- | Parse a date in the due date format (see 'formatDueDate'). -pDueDate :: Parser Day -pDueDate = label "due date" $ char 'd' *> pDate +-- | Parse a date in the due date format (see 'formatDue'). +pDue :: Parser Day +pDue = label "due date" $ char 'd' *> pDate --- | Parse a date in the creation date format (see 'formatCreationDate'). -pCreationDate :: Parser Day -pCreationDate = label "creation date" $ char 'c' *> pDate +-- | Parse a date in the creation date format (see 'formatCreated'). +pCreated :: Parser Day +pCreated = label "creation date" $ char 'c' *> pDate -- Completion @@ -263,7 +263,7 @@ pContext = char '@' *> (Context <$> wordBody) pKeyValue :: Parser Snippet pKeyValue = KeyValue <$> (keyBody <* char ':') <*> wordBody where - keyBody = takeWhile1P (Just "key character") (not . (`elem` ": \n")) + keyBody = takeWhile1P (Just "key character") (not . (`elem` ": \n")) -- | Parse a 'Description' (see 'formatDescription'). pDescription :: Parser Description @@ -300,8 +300,8 @@ pTask = Task <$> andSpace pCompletion <*> maybeParse (andSpace pPriority) - <*> maybeParse (andSpace pDueDate) - <*> maybeParse (andSpace pCreationDate) + <*> maybeParse (andSpace pDue) + <*> maybeParse (andSpace pCreated) <*> pDescription -- | Parse a list of 'Task's (see 'formatTasks'). diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs new file mode 100644 index 0000000..b53c74e --- /dev/null +++ b/src/TaskMachine/UI.hs @@ -0,0 +1,65 @@ +module TaskMachine.UI + ( myApp + , startUIState + ) where + +import qualified Brick as B +import qualified Brick.Focus as B +import qualified Brick.Themes as B +import qualified Data.Vector as V +import qualified Graphics.Vty.Input.Events as VTY + +import TaskMachine.Options +import TaskMachine.UI.NewTask +import TaskMachine.UI.TaskList +import TaskMachine.UI.TopBar +import TaskMachine.UI.Popup +import TaskMachine.UI.Types + +drawBaseLayer :: UIState -> B.Widget RName +drawBaseLayer s = B.vBox [placeholderTopBar, renderTaskList s, placeholderNewTask] + +drawUIState :: UIState -> [B.Widget RName] +drawUIState s@UIState{errorPopup=Just p} = [renderPopupOk p, drawBaseLayer s] +drawUIState s = [drawBaseLayer s] + +updateUIState :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) +-- Closing error popup +updateUIState s@UIState{errorPopup=Just _} (B.VtyEvent (VTY.EvKey VTY.KEnter [])) = B.continue s{errorPopup=Nothing} +updateUIState s@UIState{errorPopup=Just _} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.continue s{errorPopup=Nothing} +--updateUIState s@UIState{errorPopup=Just p} (B.VtyEvent e) = do +-- newPopup <- handlePopupEvent e p +-- B.continue s{errorPopup=Just newPopup} +updateUIState s e = + case B.focusGetCurrent (focus s) of + Nothing -> B.halt s + (Just BRTopBar) -> placeholderUpdate s e + --(Just BRTaskList) -> updateTaskList s e + (Just BRTaskList) -> placeholderUpdate s e + (Just BRNewTask) -> placeholderUpdate s e + +placeholderUpdate :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) +placeholderUpdate s (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.halt s +placeholderUpdate s (B.VtyEvent (VTY.EvKey (VTY.KChar '\t') [])) = B.continue $ bigFocusNext s +placeholderUpdate s (B.VtyEvent (VTY.EvKey VTY.KBackTab [])) = B.continue $ bigFocusPrev s +placeholderUpdate s _ = B.continue s + +{- Starting the app -} + +myApp :: B.App UIState () RName +myApp = B.App + { B.appDraw = drawUIState + , B.appChooseCursor = B.showFirstCursor + , B.appHandleEvent = updateUIState + , B.appStartEvent = pure + , B.appAttrMap = const (B.themeToAttrMap defaultTheme) + } + +startUIState :: Options -> UIState +startUIState o = UIState + { options = o + , focus = B.focusRing [BRTaskList, BRNewTask, BRTopBar] + , errorPopup = Nothing + , taskList = newTaskList V.empty + , invisibleTasks = V.empty + } diff --git a/src/TaskMachine/UI/NewTask.hs b/src/TaskMachine/UI/NewTask.hs new file mode 100644 index 0000000..ca119ff --- /dev/null +++ b/src/TaskMachine/UI/NewTask.hs @@ -0,0 +1,8 @@ +module TaskMachine.UI.NewTask where + +import qualified Brick as B + +import TaskMachine.UI.Types + +placeholderNewTask :: B.Widget RName +placeholderNewTask = B.str "New: " B.<+> B.vLimit 1 (B.fill '_') diff --git a/src/TaskMachine/UI/Popup.hs b/src/TaskMachine/UI/Popup.hs new file mode 100644 index 0000000..338df42 --- /dev/null +++ b/src/TaskMachine/UI/Popup.hs @@ -0,0 +1,34 @@ +module TaskMachine.UI.Popup + ( minPopupWidth + -- * Ok popup + , PopupOk + , popupOk + , popupOk' + , renderPopupOk + , handlePopupOkEvent + ) where + +import qualified Brick as B +import qualified Brick.Widgets.Dialog as B +import qualified Graphics.Vty as VTY + +minPopupWidth :: Int +minPopupWidth = 70 + +{- Ok popup -} + +data PopupOk n = PopupOk (B.Dialog ()) (B.Widget n) + +popupOk :: String -> String -> PopupOk n +popupOk title content = popupOk' title (B.str content) + +popupOk' :: String -> B.Widget n -> PopupOk n +popupOk' title widget = + let dialog = B.dialog (Just title) (Just (0,[("Ok",())])) minPopupWidth + in PopupOk dialog widget + +renderPopupOk :: PopupOk n -> B.Widget n +renderPopupOk (PopupOk dialog widget) = B.renderDialog dialog widget + +handlePopupOkEvent :: VTY.Event -> PopupOk n -> B.EventM n (PopupOk n) +handlePopupOkEvent e (PopupOk dialog widget) = PopupOk <$> B.handleDialogEvent e dialog <*> pure widget diff --git a/src/TaskMachine/UI/Task.hs b/src/TaskMachine/UI/Task.hs new file mode 100644 index 0000000..aa1a808 --- /dev/null +++ b/src/TaskMachine/UI/Task.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TaskMachine.UI.Task + ( renderTask + , renderCompletion + , renderPriority + , renderDue + , renderCreated + , renderDescription + , renderSnippet + -- * Attributes + , taskAttr + , taskCompletionAttr + , taskPriorityAttr + , taskDueAttr + , taskCreatedAttr + , taskProjectAttr + , taskContextAttr + , taskKeyValueAttr + ) where + +import Data.Maybe + +import qualified Brick as B +import Data.Time.Calendar + +import TaskMachine.Task + +withSpace :: B.Widget n -> B.Widget n +withSpace w = w B.<+> B.withDefAttr taskAttr (B.str " ") + +renderCompletion :: Completion -> B.Widget n +renderCompletion = B.withDefAttr taskCompletionAttr . B.str . formatCompletion + +renderPriority :: Priority -> B.Widget n +renderPriority p = + let name = taskPriorityAttr <> B.attrName [priorityToChar p] + in B.withDefAttr name $ B.str $ formatPriority p + +renderDue :: Day -> B.Widget n +renderDue = B.withDefAttr taskDueAttr . B.str . formatDue + +renderCreated :: Day -> B.Widget n +renderCreated = B.withDefAttr taskCreatedAttr . B.str . formatCreated + +renderDescription :: Description -> B.Widget n +renderDescription = B.withDefAttr taskAttr . B.hBox . map renderSnippet + +renderSnippet :: Snippet -> B.Widget n +renderSnippet s@(Project _) = B.withDefAttr taskProjectAttr $ B.str $ formatSnippet s +renderSnippet s@(Context _) = B.withDefAttr taskContextAttr $ B.str $ formatSnippet s +renderSnippet s@(KeyValue _ _) = B.withDefAttr taskKeyValueAttr $ B.str $ formatSnippet s +renderSnippet s = B.str $ formatSnippet s + +renderTask :: Task -> B.Widget n +renderTask t = B.hBox $ catMaybes + [ Just $ withSpace $ renderCompletion $ taskCompletion t + , (withSpace . renderPriority) <$> taskPriority t + , (withSpace . renderDue) <$> taskDue t + , (withSpace . renderCreated) <$> taskCreated t + , Just $ renderDescription $ taskDescription t + ] + +taskAttr :: B.AttrName +taskAttr = "task" + +taskCompletionAttr :: B.AttrName +taskCompletionAttr = taskAttr <> "completion" + +taskPriorityAttr :: B.AttrName +taskPriorityAttr = taskAttr <> "priority" + +taskDueAttr :: B.AttrName +taskDueAttr = taskAttr <> "due" + +taskCreatedAttr :: B.AttrName +taskCreatedAttr = taskAttr <> "created" + +taskProjectAttr :: B.AttrName +taskProjectAttr = taskAttr <> "project" + +taskContextAttr :: B.AttrName +taskContextAttr = taskAttr <> "context" + +taskKeyValueAttr :: B.AttrName +taskKeyValueAttr = taskAttr <> "keyvalue" diff --git a/src/TaskMachine/UI/TaskList.hs b/src/TaskMachine/UI/TaskList.hs new file mode 100644 index 0000000..796ffce --- /dev/null +++ b/src/TaskMachine/UI/TaskList.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TaskMachine.UI.TaskList where + +--import Data.Void + +import qualified Brick as B +import qualified Brick.Widgets.List as B +import qualified Data.Vector as V +import qualified Brick.Focus as B +import qualified Brick.Widgets.Edit as B +--import qualified Data.Text.Zipper as T +--import qualified Graphics.Vty as VTY +--import Text.Megaparsec + +import TaskMachine.LTask +import TaskMachine.Options +import TaskMachine.Task +import TaskMachine.UI.Types +import TaskMachine.UI.Task +import TaskMachine.UI.Popup + +{- Managing the tasks -} + +allTasks :: UIState -> V.Vector LTask +allTasks s = + let visible = B.listElements $ taskList s + invisible = invisibleTasks s + in visible <> invisible + +newTaskList :: V.Vector LTask -> B.List RName LTask +newTaskList ltasks = B.list RTaskList ltasks 1 + +-- TODO: Catch errors when loading tasks +loadTasks :: UIState -> IO UIState +loadTasks s = do + let file = oTodofile $ options s + result <- loadLTasks file + case result of + Left errorMessage -> pure s{errorPopup=Just $ popupOk "Error loading tasks" errorMessage} + Right ltasks -> pure s{taskList=newTaskList ltasks, invisibleTasks=V.empty} + +-- TODO: Catch errors when saving tasks +saveTasks :: UIState -> IO UIState +saveTasks s = do + let file = oTodofile $ options s + ltasks = allTasks s + saveLTasks file ltasks + pure s + +filterTasks :: (Task -> Bool) -> UIState -> UIState +filterTasks f s = + let (yes, no) = V.partition (f . toTask) (allTasks s) + in s{taskList=newTaskList yes, invisibleTasks=no} + +{- Rendering -} + +renderLTask :: Maybe (B.Editor String RName) -> Bool -> LTask -> B.Widget RName +renderLTask _ False ltask = renderTask $ toTask ltask +renderLTask Nothing True ltask = renderTask $ toTask ltask +renderLTask _ _ _ = undefined +--renderLTask (Just edit) True _ = B.renderEditor (B.str . unlines) True edit + +renderTaskList :: UIState -> B.Widget RName +renderTaskList s = + let inFocus = B.focusGetCurrent (focus s) == Just BRTaskList + in B.renderList (renderLTask Nothing) inFocus (taskList s) + +{- Updating state -} + +updateTaskList :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) +updateTaskList = undefined + +{- +widgetPriority :: B.AttrName -> Maybe Priority -> B.Widget n +widgetPriority _ Nothing = B.emptyWidget +widgetPriority highlight (Just prio) = + let attrName = highlight <> "priority" <> B.attrName [priorityToChar prio] + text = formatPriority prio ++ " " + in B.withAttr attrName $ B.str text + +widgetDescription :: B.AttrName -> String -> B.Widget n +widgetDescription highlight desc = + let attrName = highlight <> "description" + in B.withAttr attrName $ B.str desc + +renderLTask :: Bool -> LTask -> B.Widget RName +renderLTask highlight (LTask _ Task{..}) = + let attrHighlight = if highlight then "highlight" else "normal" + wCompleted = B.str $ if taskCompleted then "x " else " " + wPriority = widgetPriority attrHighlight taskPriority + wDescription = widgetDescription attrHighlight taskDescription + in B.hBox [wCompleted, wPriority, wDescription] +-} + +--type Editor = B.Editor String RName +--type TaskList = B.List RName LTask + +{- Editing tasks -} + +{- +toEditText :: Task -> String +toEditText Task{taskPriority=Nothing, taskDescription=d} = descriptionToString d +toEditText Task{taskPriority=Just p, taskDescription=d} = formatPriority p ++ " " ++ descriptionToString d + +pEditText :: Parser (Maybe Priority, String) +pEditText = undefined +--pEditText = do +-- prio <- maybeParse (andSpace pPriority) +-- notFollowedBy (andSpace pDates) +-- desc <- untilEndOfLine +-- pure (prio, desc) + +parseEditText :: String -> Either (ParseError Char Void) (Maybe Priority, String) +parseEditText = parse pEditText "edited task" +-} + +{- Updating state -} + +{- +startEdit :: UIState -> UIState +startEdit s = + case B.listSelectedElement (taskList s) of + Nothing -> s + Just (_, LTask _ t) -> + let edit = B.editor RTaskEdit (Just 1) (toEditText t) + in s{taskEdit=Just edit} + +finishEdit :: UIState -> UIState +finishEdit s@UIState{taskEdit=Just edit} = + case B.getEditContents edit of + [line] -> case parseEditText line of + Right (prio, desc) -> + --let changeTask (LTask n t) = LTask n t{taskPriority=prio, taskDescription=desc} + let changeTask (LTask n t) = LTask n t{taskPriority=prio, taskDescription=undefined desc} + newList = B.listModify changeTask (taskList s) + in s{taskList=newList, taskEdit=Nothing} + + Left parseError -> s{errorPopup=Just $ popup "Parse error" (parseErrorTextPretty parseError)} + _ -> s{errorPopup=Just $ popup "Empty editor" "Enter a task description."} +finishEdit s = s + +updateEditor :: B.Editor String RName -> VTY.Event -> B.EventM RName (B.Editor String RName) +updateEditor edit (VTY.EvKey VTY.KHome []) = pure $ B.applyEdit T.gotoBOL edit +updateEditor edit (VTY.EvKey VTY.KEnd []) = pure $ B.applyEdit T.gotoEOL edit +updateEditor edit e = B.handleEditorEvent e edit + +updateTaskList :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) +-- Exit application +updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.halt s + +-- Test stuff +updateTaskList s e = do + let changeTask (LTask n t) = LTask n t{taskDescription=show e} + newList = B.listModify changeTask (taskList s) + B.continue s{taskList=newList} + +-- Scroll focus +updateTaskList s (B.VtyEvent (VTY.EvKey VTY.KBackTab [])) = B.continue $ bigFocusPrev s +updateTaskList s (B.VtyEvent (VTY.EvKey (VTY.KChar '\t') [])) = B.continue $ bigFocusNext s +-- Start editing the current task +updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent (VTY.EvKey (VTY.KChar 'e') [])) = B.continue $ startEdit s +-- Update the task list +updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent e) = do + newList <- B.handleListEventVi B.handleListEvent e (taskList s) + B.continue s{taskList=newList} +-- Exit the editor (losing all changes) +updateTaskList s@UIState{taskEdit=Just _} (B.VtyEvent (VTY.EvKey VTY.KEsc [])) = B.continue $ s{taskEdit=Nothing} +-- Exit the editor (keeping all changes) +updateTaskList s@UIState{taskEdit=Just _} (B.VtyEvent (VTY.EvKey VTY.KEnter [])) = B.continue $ finishEdit s +-- Update the editor +updateTaskList s@UIState{taskEdit=Just edit} (B.VtyEvent e) = do + newTaskEdit <- updateEditor edit e + B.continue s{taskEdit=Just newTaskEdit} +-- Catch everything else +updateTaskList s _ = B.halt s +--updateTaskList list (Just editor) (B.VtyEvent e) = (,) <$> const list <*> B.handleEditorEvent e editor +-} diff --git a/src/TaskMachine/UI/TopBar.hs b/src/TaskMachine/UI/TopBar.hs new file mode 100644 index 0000000..16c708f --- /dev/null +++ b/src/TaskMachine/UI/TopBar.hs @@ -0,0 +1,6 @@ +module TaskMachine.UI.TopBar where + +import qualified Brick as B + +placeholderTopBar :: B.Widget n +placeholderTopBar = B.str "Prune | Reload | Search: " B.<+> B.vLimit 1 (B.fill '_') diff --git a/src/TaskMachine/UI/Types.hs b/src/TaskMachine/UI/Types.hs new file mode 100644 index 0000000..5069920 --- /dev/null +++ b/src/TaskMachine/UI/Types.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A collection of types necessary for the UI. +-- +-- These were put in a separate module to avoid an import cycle. + +module TaskMachine.UI.Types + ( RName(..) + , BigRing(..) + --, SmallRing(..) + -- * Popups + --, Popup + --, popup + --, renderPopup + --, handlePopupEvent + -- * UI state + , UIState(..) + , bigFocusNext, bigFocusPrev + --, smallFocusNext, smallFocusPrev + , defaultTheme + ) where + +import qualified Brick.Focus as B +import qualified Brick.Themes as B +import qualified Brick.Widgets.Dialog as B +import qualified Brick.Widgets.Edit as B +import qualified Brick.Widgets.List as B +import qualified Data.Vector as V +import qualified Graphics.Vty as VTY + +import TaskMachine.LTask +import TaskMachine.Options +import TaskMachine.UI.Popup +import TaskMachine.UI.Task + +-- | Resource names +data RName + = RSearchEdit + | RTaskList + | RTaskEdit + | RNewEdit + deriving (Eq, Show, Ord) + +data BigRing + = BRTopBar + | BRTaskList + | BRNewTask + deriving (Eq) + +{- +data SmallRing + = SRPurge + | SRReload + | SRSearch + deriving (Eq) +-} + +{- Popup -} + +{- +data Popup = Popup (B.Dialog ()) (B.Widget RName) + +popup :: String -> String -> Popup +popup title content = + let dialog = B.dialog (Just title) (Just (0,[("OK",())])) 70 -- with a min terminal width of 80 + widget = B.str content + in Popup dialog widget + +renderPopup :: Popup -> B.Widget RName +renderPopup (Popup dialog widget) = B.renderDialog dialog widget + +handlePopupEvent :: VTY.Event -> Popup -> B.EventM RName Popup +handlePopupEvent e (Popup dialog widget) = Popup <$> B.handleDialogEvent e dialog <*> pure widget +-} + +{- UI state -} + +data UIState = UIState + { options :: Options -- includes todo file and other config + , focus :: B.FocusRing BigRing -- focus on the top, middle or bottom part + , errorPopup :: Maybe (PopupOk RName) + + -- tasks + , taskList :: B.List RName LTask + , invisibleTasks :: V.Vector LTask + } + + + + + + + + +{- + , focus :: B.FocusRing BigRing + -- ^ 'B.FocusRing' for tab navigation + --, focusTopBar :: B.FocusRing SmallRing + -- ^ 'B.FocusRing' for the top bar, for ← and → arrow key navigation + , errorPopup :: Maybe Popup + + -- TOP BAR + --, searchEdit :: B.Editor String RName + -- ^ Content of the search field + + -- TASK LIST + , taskList :: B.List RName LTask + -- ^ List to display tasks + , invisibleTasks :: V.Vector LTask + -- ^ All tasks that aren't displayed in the taskList due to search filters + , taskEdit :: Maybe (B.Editor String RName) + -- ^ Task currently being edited + + -- NEW TASK + --, newEdit :: B.Editor String RName + -- ^ "New task" text field at the bottom + } + +-- | Create a starting UI state +startUIState :: V.Vector LTask -> UIState +startUIState ltasks = UIState + { focus = B.focusRing [BRTaskList, BRNewTask, BRTopBar] + --, focusTopBar = B.focusRing [SRPrune, SRReload, SRSearch] + , errorPopup = Nothing + --, searchEdit = B.editor RSearchEdit (Just 1) "" + , taskList = B.list RTaskList ltasks 1 + , invisibleTasks = V.empty + , taskEdit = Nothing + --, newEdit = B.editor RNewEdit (Just 1) "" + } +-} + +bigFocusNext :: UIState -> UIState +bigFocusNext s = s{focus=B.focusNext (focus s)} + +bigFocusPrev :: UIState -> UIState +bigFocusPrev s = s{focus=B.focusPrev (focus s)} + +{- +smallFocusNext :: UIState -> UIState +smallFocusNext s = s{focusTopBar=B.focusNext (focusTopBar s)} + +smallFocusPrev :: UIState -> UIState +smallFocusPrev s = s{focusTopBar=B.focusPrev (focusTopBar s)} +-} + +defaultTheme :: B.Theme +defaultTheme = B.newTheme VTY.defAttr + [ (B.dialogAttr, none) + , (B.buttonAttr, none) + , (B.buttonSelectedAttr, bg' VTY.blue) + , (B.editAttr, none) + , (B.editFocusedAttr, bg' VTY.blue) + , (B.listAttr, none) + , (B.listSelectedAttr, st' VTY.bold) + , (B.listSelectedFocusedAttr, bg VTY.blue $ st' VTY.bold) + , (taskAttr, none) + , (taskCompletionAttr, none) + , (taskPriorityAttr, fg VTY.cyan $ st' VTY.bold) + , (taskPriorityAttr <> "A", fg VTY.red $ st' VTY.bold) + , (taskPriorityAttr <> "B", fg VTY.yellow $ st' VTY.bold) + , (taskPriorityAttr <> "C", fg VTY.green $ st' VTY.bold) + , (taskDueAttr, fg' VTY.brightBlack) + , (taskCreatedAttr, fg' VTY.brightBlack) + , (taskProjectAttr, fg' VTY.yellow) + , (taskContextAttr, fg' VTY.cyan) + , (taskKeyValueAttr, fg' VTY.magenta) + ] + where + fg = flip VTY.withForeColor + bg = flip VTY.withBackColor + --st = flip VTY.withStyle + fg' = VTY.withForeColor none + bg' = VTY.withBackColor none + st' = VTY.withStyle none + none = VTY.defAttr