Garmelon/task-machine
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Compare commits

base: Garmelon:master
Branches Tags
Garmelon:master
Garmelon:new-format
..
compare: Garmelon:new-format
Branches Tags
Garmelon:master
Garmelon:new-format

No commits in common. "master" and "new-format" have entirely different histories.
master ... new-format

21 changed files with 522 additions and 640 deletions
Download patch file Download diff file Expand all files Collapse all files

43
LICENSE
View file

@ -1,21 +1,30 @@
MIT License Copyright Joscha Mennicken (c) 2018
Copyright (c) 2018 Joscha Mennicken All rights reserved.
Permission is hereby granted, free of charge, to any person obtaining a copy Redistribution and use in source and binary forms, with or without
of this software and associated documentation files (the "Software"), to deal modification, are permitted provided that the following conditions are met:
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all * Redistributions of source code must retain the above copyright
copies or substantial portions of the Software. notice, this list of conditions and the following disclaimer.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * Redistributions in binary form must reproduce the above
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, copyright notice, this list of conditions and the following
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE disclaimer in the documentation and/or other materials provided
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER with the distribution.
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE * Neither the name of Joscha Mennicken nor the names of other
SOFTWARE. contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

65
README.md
View file

@ -1,7 +1,66 @@
# task-machine # task-machine
A TUI client for the a format inspired by [todo.txt](https://github.com/todotxt/todo.txt), written in Haskell. A TUI client for the [todo.txt](https://github.com/todotxt/todo.txt) format, written in Haskell,
that supports automatically creating new tasks based on template tasks.
Still in development... For an introduction to the file format, see the [todo.txt readme](https://github.com/todotxt/todo.txt/blob/master/README.md).
![exampletodo.txt displayed using i3 and urxvt](example_screenshot.png) ## Template tasks
Template tasks allow for automatically creating new tasks on certain dates.
They work by evaluating a formula for the current day.
If the formula evaluates to `true`, a new task gets added to the current day using the template text specified.
If it evaluates to `false`, nothing happens.
When creating a template task, a start date can be specified.
In that case, the formula will be evaluated for every day from the starting date to the current date.
Once all tasks are added, the starting date will be set to one day after the current date automatically,
to avoid evaluating any day twice, even if no starting date was specified initially.
Template tasks are inspired by Ben Crowell's [when](https://github.com/bcrowell/when) calendar program.
### Format
This is the format for template tasks.
The square brackets `[]` indicate an optional part of the syntax.
The curly braces `{}` are part of the syntax.
`# [start-date] {when-formula} [priority] template-text`
- The `#` signals that this line is a template task, not a normal task.
- *Optional*: All days from `start-date` to the current date are tested when creating new tasks.
It should be in the `YYYY-MM-DD` format.
If no `start-date` is specified, it is assumed to be the current date.
- The `when-formula` is evaluated in order to decide whether a new task should be created for a day.
- *Optional*: The `priority` is a regular todo.txt priority, for example `(E)`.
- The `template-text` is pretty much a normal task description.
The only difference is that it supports date expressions.
#### Examples
`# 2018-09-08 {day_of_week == fri} clean the kitchen @home`
`# {d2018-10-20 - today >= 0} (A) daily every day up to (and including) 2018-10-20 with priority A`
`# {day == 20 && month == 10} Tom's birthday ({year - 1978} years old)`
(if Tom was born on 1978-10-20)
### Date expression
***TODO***: Document properly once it's actually implemented
- *date* + - *number* → *date*
- *date* - *date* → *number*
- *number* + - \* / *number* → *number*
- *number* == != > < >= <= *number* → *boolean*
- *boolean* && || == != *boolean* → *boolean*
### When formula
### Template text

2
app/Main.hs
View file

@ -10,4 +10,4 @@ import TaskMachine.UI
main :: IO() main :: IO()
main = do main = do
o <- parseOptions o <- parseOptions
void $ B.defaultMain myApp $ startUIState o void $ B.defaultMain myApp (startUIState o)

BIN
example_screenshot.png
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 5.5 KiB

5
package.yaml
View file

@ -28,12 +28,11 @@ dependencies:
#- bytestring #- bytestring
- containers - containers
- megaparsec - megaparsec
- mtl
- optparse-applicative - optparse-applicative
#- sqlite-simple #- sqlite-simple
#- stm #- stm
#- text #- text
- text-zipper #- text-zipper
- time - time
#- transformers #- transformers
#- unix #- unix
@ -48,7 +47,7 @@ library:
source-dirs: src source-dirs: src
executables: executables:
task-machine: task-machine-exe:
main: Main.hs main: Main.hs
source-dirs: app source-dirs: app
ghc-options: ghc-options:

24
plan.txt
View file

@ -1,24 +0,0 @@
normal task
- | x(completion date)
(priority)
(due date)
(creation date)
description
delayed task
(start date)
(priority)
(due date)
(creation date)
description
on update:
if after start date:
turn into normal task
formula task
(when formula)
(priority)
(due date)
"update":

72
src/TaskMachine/History.hs
View file

@ -1,72 +0,0 @@
-- | An undo-redo history that keeps a copy of every state.
module TaskMachine.History
( History
, history
, step
, current
, modify
, undo
, maybeUndo
, redo
, maybeRedo
) where
data Step a b = Step a b
-- | Represents the history (only one branch) of some type @a@.
--
-- Contains backwards (ctrl+z) as well as forwards (ctrl+y or ctrl+shift+z) history,
-- as well as the current state.
data History a b = History [Step a b] a [Step a b]
-- | Create a new 'History' from a single state.
history :: a -> History a b
history a = History [] a []
-- | Add a new step to the history.
--
-- Any forwards history will be overwritten, as this action starts a new
-- branch in the history tree.
step :: a -> b -> History a b -> History a b
step a (History xs y _) = History (Step y b : xs) a []
-- | Read the current state of the history.
current :: History a -> b -> a
current (History _ a _) = a
{-
-- | Modify the current state, adding a step in the process.
--
-- @'modify' f h = 'step' (f $ 'current' h) h@
modify :: (a -> a) -> History a -> History a -- not a functor!
modify f h = step (f $ current h) h
-}
-- | Jump to the previous state, remembering the future for later redos.
--
-- If there is no previous state, do nothing.
undo :: History a b -> Maybe (History a b, b)
undo (History (Step x b : xs) y zs) = Just (History xs x (Step y b : zs), b)
undo _ = Nothing
{-
-- | Like 'undo', but returns 'Nothing' if there was no previous state.
maybeUndo :: History a -> Maybe (History a)
maybeUndo (History (x:xs) y zs) = Just $ History xs x (y:zs)
maybeUndo _ = Nothing
-}
-- | Jump to the next state, remembering the past for later undos.
--
-- If there is no next state, do nothing.
redo :: History a b -> Maybe (History a b, b)
redo (History xs y (Step z b : zs)) = Just (History (Step y b : xs) z zs, b)
redo _ = Nothing
{-
-- | Like 'redo', but returns 'Nothing' if there was no next state.
maybeRedo :: History a -> Maybe (History a)
maybeRedo (History xs y (z:zs)) = Just $ History (y:xs) z zs
maybeRedo _ = Nothing
-}

38
src/TaskMachine/LTask.hs
View file

@ -20,12 +20,10 @@ module TaskMachine.LTask
, saveLTasks , saveLTasks
) where ) where
import Control.Exception
import Data.Function import Data.Function
import Data.List import Data.List
import System.IO.Error
import qualified Data.Vector as V import qualified Data.Vector as V
import Text.Megaparsec import Text.Megaparsec
import TaskMachine.Task import TaskMachine.Task
@ -56,36 +54,14 @@ modifyLTask f (LTask pos task) = LTask pos (f task)
sortLTasks :: [LTask] -> [LTask] sortLTasks :: [LTask] -> [LTask]
sortLTasks = sortBy (compare `on` lPosition) sortLTasks = sortBy (compare `on` lPosition)
{- Loading -}
data ErrorAction
= ErrorMessage String
| IgnoreError
deriving (Show)
loadErrorMessage :: IOError -> Maybe ErrorAction
loadErrorMessage e
| isDoesNotExistError e = Just IgnoreError
| otherwise = Just $ ErrorMessage $ show e
loadLTasks :: FilePath -> IO (Either String (V.Vector LTask)) loadLTasks :: FilePath -> IO (Either String (V.Vector LTask))
loadLTasks file = do loadLTasks file = do
content <- tryJust loadErrorMessage $ readFile file content <- readFile file
case parse pTasks file <$> content of case parse pTasks file content of
Left IgnoreError -> pure $ Right V.empty Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList
Left (ErrorMessage msg) -> pure $ Left msg Left parseError -> pure $ Left $ parseErrorPretty parseError
Right (Left parseError) -> pure $ Left $ parseErrorPretty parseError
Right (Right taskList) -> pure $ Right $ V.fromList $ fromTasks taskList
{- Saving -} saveLTasks :: FilePath -> V.Vector LTask -> IO ()
saveErrorMessage :: IOError -> Maybe String
saveErrorMessage e = Just $ show e
saveLTasks :: FilePath -> V.Vector LTask -> IO (Either String ())
saveLTasks file ltasks = do saveLTasks file ltasks = do
let text = formatTasks $ toTasks $ V.toList ltasks let text = formatTasks $ toTasks $ V.toList ltasks
result <- tryJust saveErrorMessage $ writeFile file text writeFile file text
case result of
Left ioErrorMessage -> pure $ Left ioErrorMessage
Right _ -> pure $ Right ()

65
src/TaskMachine/Task.hs
View file

@ -21,12 +21,9 @@ module TaskMachine.Task
, Description , Description
, Snippet(..) , Snippet(..)
-- * Misc stuff -- * Misc stuff
, emptyTask
, newTask
, compareTasks , compareTasks
-- * Formatting -- * Formatting
, formatTask , formatTask
, formatTaskHalves
, formatTasks , formatTasks
, formatDate , formatDate
, formatDue , formatDue
@ -74,23 +71,6 @@ data Task = Task
, taskDescription :: Description , taskDescription :: Description
} deriving (Show) } deriving (Show)
-- | Convert a 'Task' to its string representation.
-- This string representation is split into a pre-description and a description part.
--
-- For further detail, see 'formatTask'
formatTaskHalves :: Task -> (String, String)
formatTaskHalves t =
( formatCompletion (taskCompletion t) ++ " "
++ maybeWithSpace formatPriority (taskPriority t)
++ maybeWithSpace formatDue(taskDue t)
++ maybeWithSpace formatCreated (taskCreated t)
, formatDescription (taskDescription t)
)
where
maybeWithSpace :: (a -> String) -> Maybe a -> String
maybeWithSpace _ Nothing = ""
maybeWithSpace f (Just a) = f a ++ " "
-- | Convert a 'Task' to its string representation, which can be parsed by 'pTask'. -- | Convert a 'Task' to its string representation, which can be parsed by 'pTask'.
-- --
-- If this string representation is parsed using 'pTask', it should yield the original task, -- If this string representation is parsed using 'pTask', it should yield the original task,
@ -99,9 +79,16 @@ formatTaskHalves t =
-- could include the text version of these in the beginning, i. e. @taskDescription = "(A) hello"@. -- could include the text version of these in the beginning, i. e. @taskDescription = "(A) hello"@.
-- In that case, converting the task to a string and back yields a different result. -- In that case, converting the task to a string and back yields a different result.
formatTask :: Task -> String formatTask :: Task -> String
formatTask t = formatTask t
let (predesc, desc) = formatTaskHalves t = formatCompletion (taskCompletion t) ++ " "
in predesc ++ desc ++ maybeWithSpace formatPriority (taskPriority t)
++ maybeWithSpace formatDue(taskDue t)
++ maybeWithSpace formatCreated (taskCreated t)
++ formatDescription (taskDescription t)
where
maybeWithSpace :: (a -> String) -> Maybe a -> String
maybeWithSpace _ Nothing = ""
maybeWithSpace f (Just a) = f a ++ " "
-- | Convert a list of tasks to its string representation, which can be parsed by 'pTasks'. -- | Convert a list of tasks to its string representation, which can be parsed by 'pTasks'.
formatTasks :: [Task] -> String formatTasks :: [Task] -> String
@ -326,33 +313,19 @@ pTasks = many pTask <* eof
{- Misc stuff -} {- Misc stuff -}
emptyTask :: Task
emptyTask = Task Incomplete Nothing Nothing Nothing []
-- | Create a new task with empty description and the given date as creation date
newTask :: Day -> Task
newTask day = Task Incomplete Nothing Nothing (Just day) []
-- Inverted compare for Maybes: Nothing comes after Just
compareMaybe :: Ord a => Maybe a -> Maybe a -> Ordering
compareMaybe Nothing Nothing = EQ
compareMaybe (Just _) Nothing = LT
compareMaybe Nothing (Just _) = GT
compareMaybe (Just x) (Just y) = compare x y
compareDescription :: Description -> Description -> Ordering
compareDescription = compare `on` formatDescription
compareTasks :: Task -> Task -> Ordering compareTasks :: Task -> Task -> Ordering
compareTasks a@(Task (Complete _) _ _ _ _) b@(Task (Complete _) _ _ _ _) = mconcat
[ compare (taskCompletion b) (taskCompletion a)
, compareMaybe (taskPriority a) (taskPriority b)
, compareMaybe (taskDue a) (taskDue b)
, compareDescription (taskDescription a) (taskDescription b)
]
compareTasks a b = mconcat compareTasks a b = mconcat
[ compare (taskCompletion a) (taskCompletion b) [ compare (taskCompletion a) (taskCompletion b)
, compareMaybe (taskPriority a) (taskPriority b) , compareMaybe (taskPriority a) (taskPriority b)
, compareMaybe (taskDue a) (taskDue b) , compareMaybe (taskDue a) (taskDue b)
, compareDescription (taskDescription a) (taskDescription b) , compareDescription (taskDescription a) (taskDescription b)
] ]
where
-- Inverted compare for Maybes: Nothing comes after Just
compareMaybe :: Ord a => Maybe a -> Maybe a -> Ordering
compareMaybe Nothing Nothing = EQ
compareMaybe (Just _) Nothing = LT
compareMaybe Nothing (Just _) = GT
compareMaybe (Just x) (Just y) = compare x y
compareDescription :: Description -> Description -> Ordering
compareDescription = compare `on` formatDescription

68
src/TaskMachine/UI.hs
View file

@ -4,39 +4,75 @@ module TaskMachine.UI
) where ) where
import qualified Brick as B import qualified Brick as B
import qualified Brick.Focus as B
import qualified Brick.Themes as B import qualified Brick.Themes as B
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Graphics.Vty.Input.Events as VTY import qualified Graphics.Vty.Input.Events as VTY
import TaskMachine.Options import TaskMachine.Options
import TaskMachine.UI.Behaviors import TaskMachine.UI.NewTask
import TaskMachine.UI.Popup import TaskMachine.UI.Popup
import TaskMachine.UI.TaskList import TaskMachine.UI.TaskList
import TaskMachine.UI.TopBar
import TaskMachine.UI.Types import TaskMachine.UI.Types
{- Rendering -} {- Rendering -}
drawTaskList :: UIState -> B.Widget RName drawBaseLayer :: UIState -> B.Widget RName
drawTaskList s = renderTaskList (editor s) True (tasks s) drawBaseLayer s = B.vBox [placeholderTopBar, renderTaskList True (tasks s), placeholderNewTask]
drawUIState :: UIState -> [B.Widget RName] drawUIState :: UIState -> [B.Widget RName]
drawUIState s@UIState{errorPopup=Just p} = [renderPopup p, drawTaskList s] drawUIState s@UIState{errorPopup=Just p} = [renderPopupOk p, drawBaseLayer s]
drawUIState s = [drawTaskList s] drawUIState s = [drawBaseLayer s]
{- Updating the state -} {- Updating the state -}
rootBehavior :: UIState -> VTY.Event -> NewState
rootBehavior s _ = B.continue s
closeBehavior :: (UIState -> VTY.Event -> NewState) -> UIState -> VTY.Event -> NewState
closeBehavior _ s (VTY.EvKey VTY.KEsc []) = B.halt s
closeBehavior _ s (VTY.EvKey (VTY.KChar 'q') []) = B.halt s
closeBehavior f s e = f s e -- wrapper around another behavior
{-
focusBehavior :: (UIState -> VTY.Event -> Result) -> UIState -> VTY.Event -> Result
focusBehavior _ s (VTY.EvKey (VTY.KChar '\t') []) = B.continue $ bigFocusNext s
focusBehavior _ s (VTY.EvKey VTY.KBackTab []) = B.continue $ bigFocusPrev s
focusBehavior f s e = f s e -- wrapper around another behavior
-}
selectBehavior :: UIState -> VTY.Event -> NewState selectBehavior :: UIState -> VTY.Event -> NewState
-- Deal with popup if there is one selectBehavior s@UIState{errorPopup=Just popup} e = undefined popup s e
selectBehavior s@UIState{errorPopup=Just p} e = closeModifier (popupBehavior p) s e selectBehavior s e = closeBehavior rootBehavior s e
-- Continue editing task if previously editing a task
selectBehavior s@UIState{editor=Just edit} e = taskEditBehavior edit s e
-- Default task list behavior
selectBehavior s e = closeModifier taskListBehavior s e
updateUIState :: UIState -> B.BrickEvent RName () -> NewState updateUIState :: UIState -> B.BrickEvent RName () -> NewState
updateUIState s (B.VtyEvent e) = selectBehavior s e updateUIState s (B.VtyEvent e) = selectBehavior s e
updateUIState s _ = B.continue s updateUIState s _ = B.continue 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 -} {- Starting the app -}
myApp :: B.App UIState () RName myApp :: B.App UIState () RName
@ -44,14 +80,14 @@ myApp = B.App
{ B.appDraw = drawUIState { B.appDraw = drawUIState
, B.appChooseCursor = B.showFirstCursor , B.appChooseCursor = B.showFirstCursor
, B.appHandleEvent = updateUIState , B.appHandleEvent = updateUIState
, B.appStartEvent = actionLoad , B.appStartEvent = pure
, B.appAttrMap = const (B.themeToAttrMap defaultTheme) , B.appAttrMap = const (B.themeToAttrMap defaultTheme)
} }
startUIState :: Options -> UIState startUIState :: Options -> UIState
startUIState o = UIState startUIState o = UIState
{ options = o { options = o
, errorPopup = Nothing , focus = B.focusRing [BRTaskList, BRNewTask, BRTopBar]
, tasks = taskList RTaskList V.empty , errorPopup = Nothing
, editor = Nothing , tasks = taskList RTaskList V.empty
} }

215
src/TaskMachine/UI/Behaviors.hs
View file

@ -1,215 +0,0 @@
module TaskMachine.UI.Behaviors
( Behavior
-- * Miscellaneous
, getCurrentDay
, closeModifier
-- * Behaviors
, popupBehavior
, taskListBehavior
, taskEditBehavior
-- * Actions
, actionLoad
, actionSave
, actionDelete
, actionEditNew
, actionEditSelected
, actionToggleCompletion
, actionSortTasks
, actionFinishEdit
) where
import Control.Monad
import qualified Brick as B
import Control.Monad.Trans
import Data.Time
import qualified Graphics.Vty as VTY
import TaskMachine.LTask
import TaskMachine.Options
import TaskMachine.Task
import TaskMachine.UI.Popup
import TaskMachine.UI.TaskEdit
import TaskMachine.UI.TaskList
import TaskMachine.UI.Types
type Behavior = UIState -> VTY.Event -> B.EventM RName (B.Next UIState)
type Action = UIState -> B.EventM RName UIState
{- Miscellaneous -}
getCurrentDay :: IO Day
getCurrentDay = utctDay <$> liftIO getCurrentTime
closeModifier :: Behavior -> Behavior
closeModifier _ s (VTY.EvKey VTY.KEsc []) = B.halt s
closeModifier _ s (VTY.EvKey (VTY.KChar 'q') []) = B.halt s
closeModifier f s e = f s e -- wrapper around another behavior
{- Popups -}
popupBehavior :: Popup RName (UIState -> NewState) -> Behavior
popupBehavior p s (VTY.EvKey VTY.KEnter []) =
case popupSelection p of
Nothing -> B.continue s{errorPopup=Nothing} -- Just close, no action was specified
Just action -> action s{errorPopup=Nothing} -- Do the thing! (and close the popup)
popupBehavior p s e = do
newPopup <- handlePopupEvent e p
B.continue s{errorPopup=Just newPopup}
{- On the task list -}
-- (re-)loading
actionLoad :: Action
actionLoad s = do
let file = oTodofile $ options s
result <- liftIO $ loadLTasks file
case result of
Right ltasks -> pure s{tasks=taskList RTaskList ltasks}
Left errorMessage ->
let p = popup "Error loading tasks" errorMessage
[ ("Retry", actionLoad >=> B.continue)
, ("Quit", B.halt)
]
in pure s{errorPopup=Just p}
-- saving
actionSave :: Action
actionSave s = do
let filepath = oTodofile (options s)
ltasks = taskListElements (tasks s)
result <- liftIO $ saveLTasks filepath ltasks
case result of
Right _ -> pure s
Left errorMessage ->
let p = popup "Error saving tasks" errorMessage
[ ("Retry", actionSave >=> B.continue)
, ("Continue without saving", B.continue)
, ("Quit", B.halt)
]
in pure s{errorPopup=Just p}
-- deleting a task
actionDelete :: Action
actionDelete s = pure s{tasks=deleteTask (tasks s)}
-- beginning an edit
actionEditNew :: Action
actionEditNew s = do
today <- liftIO getCurrentDay
let task = newTask today
edit = taskEdit RTaskEdit task NewTask
pure s{editor=Just edit}
actionEditSelected :: Action
actionEditSelected s =
case selectedTask (tasks s) of
Nothing -> pure s
Just t ->
let edit = taskEdit RTaskEdit t ExistingTask
in pure s{editor=Just edit}
-- toggling completion
actionToggleCompletion :: Action
actionToggleCompletion s =
case selectedTask (tasks s) of
Nothing -> pure s
Just task -> do
newCompletion <- case taskCompletion task of
Complete _ -> pure Incomplete
Incomplete -> Complete . Just <$> liftIO getCurrentDay
let task' = task{taskCompletion=newCompletion}
newTaskList = replaceTask task' (tasks s)
pure s{tasks=newTaskList}
-- sorting
actionSortTasks :: Action
actionSortTasks s = pure s{tasks=sortTaskList (tasks s)}
-- cleaning up tasks
cleanUpTask :: Day -> Task -> Task
cleanUpTask today (Task (Complete Nothing) p d Nothing desc) =
Task (Complete (Just today)) p d (Just today) desc
cleanUpTask today (Task (Complete Nothing) p d c desc) =
Task (Complete (Just today)) p d c desc
cleanUpTask today (Task c p d Nothing desc) =
Task c p d (Just today) desc
cleanUpTask _ t = t
actionCleanUp :: Action
actionCleanUp s = do
today <- liftIO getCurrentDay
let tasks' = modifyAllTasks (cleanUpTask today) (tasks s)
pure s{tasks=tasks'}
-- combining all of the above...
taskListBehavior :: Behavior
-- Clean up: Add todays date where creation/completion date is missing
taskListBehavior s (VTY.EvKey (VTY.KChar 'c') []) =
actionCleanUp >=> actionSave >=> B.continue $ s
-- Delete currently selected task (implicit save)
taskListBehavior s (VTY.EvKey (VTY.KChar 'd') []) =
actionDelete >=> actionSave >=> B.continue $ s
-- Begin editing currently selected task
taskListBehavior s (VTY.EvKey (VTY.KChar 'e') []) =
actionEditSelected >=> B.continue $ s
-- Begin creating new task
taskListBehavior s (VTY.EvKey (VTY.KChar 'n') []) =
actionEditNew >=> B.continue $ s
-- Reload tasks (and sort them)
taskListBehavior s (VTY.EvKey (VTY.KChar 'r') []) =
actionLoad >=> B.continue $ s
-- Sort tasks
taskListBehavior s (VTY.EvKey (VTY.KChar 's') []) =
actionSortTasks >=> B.continue $ s
-- Toggle completion (implicit save)
taskListBehavior s (VTY.EvKey (VTY.KChar 'x') []) =
actionToggleCompletion >=> actionSave >=> B.continue $ s
-- Update the task list (scroll etc.)
taskListBehavior s e = do
newTasks <- updateTaskList e (tasks s)
B.continue s{tasks=newTasks}
{- In the task editor -}
actionFinishEdit :: TaskEdit RName -> Action
actionFinishEdit t = pure . finishEdit t
-- get result of task editing
-- if editing an existing task, modify that task
-- if editing a new task, append that task
finishEdit :: TaskEdit RName -> UIState -> UIState
finishEdit edit s =
case editedTask edit of
Left e ->
let p = popup "Syntax error" e
[ ("Continue editing", B.continue)
, ("Abort", \s' -> B.continue s'{editor=Nothing})
]
in s{errorPopup=Just p}
Right task -> s{tasks=modify task, editor=Nothing}
where
modify :: Task -> TaskList RName
modify task = case editState edit of
ExistingTask -> replaceTask task $ tasks s
NewTask -> appendTask task $ tasks s
taskEditBehavior :: TaskEdit RName -> Behavior
taskEditBehavior _ s (VTY.EvKey VTY.KEsc []) = B.continue s{editor=Nothing}
taskEditBehavior edit s (VTY.EvKey VTY.KEnter []) =
actionFinishEdit edit >=> actionSave >=> B.continue $ s
--taskEditBehavior edit s (VTY.EvKey VTY.KEnter []) = do
-- newState <- liftIO $ saveTasks $ finishEdit edit s
-- B.continue newState
taskEditBehavior edit s e = do
newEdit <- updateTaskEdit e edit
B.continue s{editor=Just newEdit}

8
src/TaskMachine/UI/NewTask.hs Normal file
View file

@ -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 '_')

52
src/TaskMachine/UI/Popup.hs
View file

@ -1,36 +1,34 @@
module TaskMachine.UI.Popup module TaskMachine.UI.Popup
( Popup ( minPopupWidth
, popup -- * Ok popup
, popup' , PopupOk
, renderPopup , popupOk
, handlePopupEvent , popupOk'
, popupSelection , renderPopupOk
, minPopupWidth , handlePopupOkEvent
) where ) where
import qualified Brick as B import qualified Brick as B
import qualified Brick.Widgets.Dialog as B import qualified Brick.Widgets.Dialog as B
import qualified Graphics.Vty as VTY import qualified Graphics.Vty as VTY
data Popup n r = Popup (B.Dialog r) (B.Widget n)
popup :: String -> String -> [(String, r)] -> Popup n r
popup title content = popup' title (B.str content)
popup' :: String -> B.Widget n -> [(String, r)] -> Popup n r
popup' title widget results =
let spacedTitle = " " ++ title ++ " "
dialog = B.dialog (Just spacedTitle) (Just (0, results)) minPopupWidth
in Popup dialog widget
renderPopup :: Popup n r -> B.Widget n
renderPopup (Popup dialog widget) = B.renderDialog dialog widget
handlePopupEvent :: VTY.Event -> Popup n r -> B.EventM n (Popup n r)
handlePopupEvent e (Popup dialog widget) = Popup <$> B.handleDialogEvent e dialog <*> pure widget
popupSelection :: Popup n r -> Maybe r
popupSelection (Popup dialog _) = B.dialogSelection dialog
minPopupWidth :: Int minPopupWidth :: Int
minPopupWidth = 78 minPopupWidth = 78
{- 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

5
src/TaskMachine/UI/Task.hs
View file

@ -30,10 +30,7 @@ withSpace :: B.Widget n -> B.Widget n
withSpace w = w B.<+> B.withDefAttr taskAttr (B.str " ") withSpace w = w B.<+> B.withDefAttr taskAttr (B.str " ")
renderCompletion :: Completion -> B.Widget n renderCompletion :: Completion -> B.Widget n
renderCompletion Incomplete = B.str "-" renderCompletion = B.withDefAttr taskCompletionAttr . B.str . formatCompletion
renderCompletion (Complete Nothing) = B.str "x"
renderCompletion (Complete (Just day)) =
B.str "x" B.<+> B.withDefAttr taskCompletionAttr (B.str $ formatDate day)
renderPriority :: Priority -> B.Widget n renderPriority :: Priority -> B.Widget n
renderPriority p = renderPriority p =

69
src/TaskMachine/UI/TaskEdit.hs
View file

@ -1,69 +0,0 @@
module TaskMachine.UI.TaskEdit
( TaskEdit
, EditState(..)
, taskEdit
, editState
, editedTask
, renderTaskEdit
, updateTaskEdit
) where
import qualified Brick 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.Task
import TaskMachine.UI.Task
data TaskEdit n = TaskEdit EditState (B.Editor String n)
deriving (Show)
data EditState = ExistingTask | NewTask
deriving (Show)
taskEdit :: n -> Task -> EditState -> TaskEdit n
taskEdit name task s =
let (predesc, desc) = formatTaskHalves task
formattedTask = predesc ++ desc
cursor = length predesc
editor = B.editor name (Just 1) formattedTask
newEditor = B.applyEdit (T.moveCursor (0, cursor)) editor
in TaskEdit s newEditor
editState :: TaskEdit n -> EditState
editState (TaskEdit s _) = s
editedLine :: TaskEdit n -> Either String String
editedLine (TaskEdit _ edit) =
case B.getEditContents edit of
[s] -> Right s
_ -> Left "Editor empty"
editedTask :: TaskEdit n -> Either String Task
editedTask te = do
s <- editedLine te
case parse pTask "task editor" s of
Left parseError -> Left $ parseErrorPretty parseError
Right task -> Right task
renderRow :: String -> B.Widget n
renderRow s =
case parse pTask "" s of
Left _ -> B.str s
Right task -> renderTask task
renderRows :: [String] -> B.Widget n
renderRows = B.vBox . map renderRow
renderTaskEdit :: (Ord n, Show n) => Bool -> TaskEdit n -> B.Widget n
renderTaskEdit focus (TaskEdit _ edit) = B.renderEditor renderRows focus edit
updateTaskEdit :: Ord n => VTY.Event -> TaskEdit n -> B.EventM n (TaskEdit n)
updateTaskEdit (VTY.EvKey VTY.KHome []) (TaskEdit s edit) =
pure $ TaskEdit s $ B.applyEdit T.gotoBOL edit
updateTaskEdit (VTY.EvKey VTY.KEnd []) (TaskEdit s edit) =
pure $ TaskEdit s $ B.applyEdit T.gotoEOL edit
updateTaskEdit event (TaskEdit s edit) =
TaskEdit s <$> B.handleEditorEvent event edit

271
src/TaskMachine/UI/TaskList.hs
View file

@ -1,107 +1,224 @@
module TaskMachine.UI.TaskList module TaskMachine.UI.TaskList
( TaskList ( TaskList
, taskList , taskList
, taskListElements
, renderTaskList , renderTaskList
, updateTaskList , taskListElements
, sortTaskList , taskListFilter
, selectedTask , taskListSelectedElement
, appendTask , taskListModify
, replaceTask
, deleteTask
, modifyAllTasks
) where ) where
import Data.Function --import Data.Void
import Data.List
import qualified Brick as B import qualified Brick as B
import qualified Brick.Widgets.List as B import qualified Brick.Widgets.List as B
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Graphics.Vty as VTY --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.LTask
import TaskMachine.Task import TaskMachine.Task
import TaskMachine.UI.Task import TaskMachine.UI.Task
import TaskMachine.UI.TaskEdit --import TaskMachine.Options
--import TaskMachine.UI.Popup
--import TaskMachine.UI.Types
newtype TaskList n = TaskList (B.List n LTask) data TaskList n = TaskList
{ visibleTasks :: B.List n LTask
, invisibleTasks :: V.Vector LTask
} deriving (Show)
newList :: n -> V.Vector LTask -> B.List n LTask
newList name ltasks = B.list name ltasks 1
taskList :: n -> V.Vector LTask -> TaskList n taskList :: n -> V.Vector LTask -> TaskList n
taskList name tasks = TaskList $ B.list name tasks 1 taskList name ltasks = TaskList{visibleTasks=newList name ltasks, invisibleTasks=V.empty}
-- TODO: render while editing
renderTaskList :: (Ord n, Show n) => Bool -> TaskList n -> B.Widget n
renderTaskList focus tl = B.renderList (const $ renderTask . toTask) focus (visibleTasks tl)
{- Managing tasks -}
taskListElements :: TaskList n -> V.Vector LTask taskListElements :: TaskList n -> V.Vector LTask
taskListElements (TaskList list) = B.listElements list taskListElements tl = B.listElements (visibleTasks tl) <> invisibleTasks tl
renderRow :: Maybe (B.Widget n) -> Bool -> LTask -> B.Widget n taskListFilter :: (Task -> Bool) -> TaskList n -> TaskList n
renderRow (Just w) True _ = w taskListFilter f tl =
renderRow _ _ lt = renderTask (toTask lt) let (yes, no) = V.partition (f . toTask) $ taskListElements tl
name = B.listName (visibleTasks tl)
list = newList name yes
in TaskList{visibleTasks=list, invisibleTasks=no}
renderLast :: (Ord n, Show n) => B.Widget n -> Bool -> B.List n LTask -> B.Widget n taskListSelectedElement :: TaskList n -> Maybe Task
renderLast widget focus list = taskListSelectedElement tl = toTask . snd <$> B.listSelectedElement (visibleTasks tl)
let listWithPlaceholder = focusOnLastTask $ appendTask' emptyTask list
in B.renderList (renderRow (Just widget)) focus listWithPlaceholder
renderTaskList :: (Ord n, Show n) => Maybe (TaskEdit n) -> Bool -> TaskList n -> B.Widget n taskListModify :: (Task -> Task) -> TaskList n -> TaskList n
renderTaskList Nothing focus (TaskList list) taskListModify f tl =
| listSize list == 0 = renderLast (B.str "--- empty ---") focus list let list = B.listModify (modifyLTask f) (visibleTasks tl)
| otherwise = B.renderList (renderRow Nothing) focus list in tl{visibleTasks=list}
renderTaskList (Just te) focus (TaskList list) =
case editState te of
ExistingTask -> B.renderList (renderRow (Just teWidget)) focus list
NewTask -> renderLast teWidget focus list
where
teWidget = renderTaskEdit focus te
updateTaskList :: Ord n => VTY.Event -> TaskList n -> B.EventM n (TaskList n) {-
updateTaskList event (TaskList list) = {- Managing the tasks -}
TaskList <$> B.handleListEventVi B.handleListEvent event list
sortTaskList :: TaskList n -> TaskList n allTasks :: UIState -> V.Vector LTask
sortTaskList (TaskList list) = allTasks s =
let index = B.listSelected list let visible = B.listElements $ taskList s
tasks = V.toList $ B.listElements list invisible = invisibleTasks s
sortedTasks = sortBy (compareTasks `on` toTask) tasks in visible <> invisible
newVector = V.fromList sortedTasks
in TaskList $ B.listReplace newVector index list
selectedTask :: TaskList n -> Maybe Task newTaskList :: V.Vector LTask -> B.List RName LTask
selectedTask (TaskList list) = toTask . snd <$> B.listSelectedElement list newTaskList ltasks = B.list RTaskList ltasks 1
appendTask' :: Task -> B.List n LTask -> B.List n LTask -- TODO: Catch errors when loading tasks
appendTask' task list = loadTasks :: UIState -> IO UIState
let size = listSize list loadTasks s = do
lt = lTask task let file = oTodofile $ options s
in focusOnLastTask $ B.listInsert size lt list 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}
appendTask :: Task -> TaskList n -> TaskList n -- TODO: Catch errors when saving tasks
appendTask task (TaskList list) = TaskList $ appendTask' task list saveTasks :: UIState -> IO UIState
saveTasks s = do
let file = oTodofile $ options s
ltasks = allTasks s
saveLTasks file ltasks
pure s
replaceTask :: Task -> TaskList n -> TaskList n filterTasks :: (Task -> Bool) -> UIState -> UIState
replaceTask task (TaskList list) = TaskList $ B.listModify replace list filterTasks f s =
where let (yes, no) = V.partition (f . toTask) (allTasks s)
replace :: LTask -> LTask in s{taskList=newTaskList yes, invisibleTasks=no}
replace = modifyLTask (const task)
deleteTask :: TaskList n -> TaskList n {- Rendering -}
deleteTask tl@(TaskList list) =
case B.listSelected list of
Nothing -> tl
Just index
| index == 0 -> TaskList $ B.listRemove index list
| otherwise -> TaskList $ B.listMoveBy 1 $ B.listRemove index list
modifyAllTasks :: (Task -> Task) -> TaskList n -> TaskList n renderLTask :: Maybe (B.Editor String RName) -> Bool -> LTask -> B.Widget RName
modifyAllTasks f (TaskList list) = renderLTask _ False ltask = renderTask $ toTask ltask
let index = B.listSelected list renderLTask Nothing True ltask = renderTask $ toTask ltask
vector = B.listElements list renderLTask _ _ _ = undefined
vector' = V.map (modifyLTask f) vector --renderLTask (Just edit) True _ = B.renderEditor (B.str . unlines) True edit
in TaskList $ B.listReplace vector' index list
{- helper functions -} renderTaskList :: UIState -> B.Widget RName
renderTaskList s =
let inFocus = B.focusGetCurrent (focus s) == Just BRTaskList
in B.renderList (renderLTask Nothing) inFocus (taskList s)
listSize :: B.List n e -> Int {- Updating state -}
listSize list = V.length $ B.listElements list
focusOnLastTask :: B.List n e -> B.List n e taskListBehavior :: UIState -> VTY.Event -> NewState
focusOnLastTask list = B.listMoveTo (listSize list - 1) list taskListBehavior = undefined
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
-}

6
src/TaskMachine/UI/TopBar.hs Normal file
View file

@ -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 '_')

117
src/TaskMachine/UI/Types.hs
View file

@ -6,42 +6,149 @@
module TaskMachine.UI.Types module TaskMachine.UI.Types
( RName(..) ( RName(..)
, BigRing(..)
--, SmallRing(..)
-- * Popups
--, Popup
--, popup
--, renderPopup
--, handlePopupEvent
-- * UI state -- * UI state
, UIState(..) , UIState(..)
, NewState , NewState
, bigFocusNext, bigFocusPrev
--, smallFocusNext, smallFocusPrev
, defaultTheme , defaultTheme
) where ) where
import qualified Brick as B import qualified Brick as B
import qualified Brick.Focus as B
import qualified Brick.Themes as B import qualified Brick.Themes as B
import qualified Brick.Widgets.Dialog as B import qualified Brick.Widgets.Dialog as B
import qualified Brick.Widgets.Edit as B import qualified Brick.Widgets.Edit as B
import qualified Brick.Widgets.List as B import qualified Brick.Widgets.List as B
import qualified Graphics.Vty as VTY import qualified Graphics.Vty as VTY
--import qualified Data.Vector as V
--import TaskMachine.LTask
import TaskMachine.Options import TaskMachine.Options
import TaskMachine.UI.Popup import TaskMachine.UI.Popup
import TaskMachine.UI.Task import TaskMachine.UI.Task
import TaskMachine.UI.TaskEdit
import TaskMachine.UI.TaskList import TaskMachine.UI.TaskList
-- | Resource names -- | Resource names
data RName data RName
= RTaskList = RSearchEdit
| RTaskList
| RTaskEdit | RTaskEdit
| RNewEdit
deriving (Eq, Show, Ord) 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 -} {- UI state -}
data UIState = UIState data UIState = UIState
{ options :: Options -- includes todo file and other config { options :: Options -- includes todo file and other config
, errorPopup :: Maybe (Popup RName (UIState -> NewState)) , focus :: B.FocusRing BigRing -- focus on the top, middle or bottom part
-- popups
, errorPopup :: Maybe (PopupOk RName)
-- tasks
, tasks :: TaskList RName , tasks :: TaskList RName
, editor :: Maybe (TaskEdit RName)
} }
type NewState = B.EventM RName (B.Next UIState) type NewState = B.EventM RName (B.Next UIState)
{-
, 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.Theme
defaultTheme = B.newTheme VTY.defAttr defaultTheme = B.newTheme VTY.defAttr
[ (B.dialogAttr, none) [ (B.dialogAttr, none)
@ -53,7 +160,7 @@ defaultTheme = B.newTheme VTY.defAttr
, (B.listSelectedAttr, st' VTY.bold) , (B.listSelectedAttr, st' VTY.bold)
, (B.listSelectedFocusedAttr, bg VTY.blue $ st' VTY.bold) , (B.listSelectedFocusedAttr, bg VTY.blue $ st' VTY.bold)
, (taskAttr, none) , (taskAttr, none)
, (taskCompletionAttr, fg' VTY.brightBlack) , (taskCompletionAttr, none)
, (taskPriorityAttr, fg VTY.cyan $ st' VTY.bold) , (taskPriorityAttr, fg VTY.cyan $ st' VTY.bold)
, (taskPriorityAttr <> "A", fg VTY.red $ st' VTY.bold) , (taskPriorityAttr <> "A", fg VTY.red $ st' VTY.bold)
, (taskPriorityAttr <> "B", fg VTY.yellow $ st' VTY.bold) , (taskPriorityAttr <> "B", fg VTY.yellow $ st' VTY.bold)

2
stack.yaml
View file

@ -15,7 +15,7 @@
# resolver: # resolver:
# name: custom-snapshot # name: custom-snapshot
# location: "./custom-snapshot.yaml" # location: "./custom-snapshot.yaml"
resolver: lts-12.14 resolver: lts-12.9
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.

7
test.txt
View file

@ -1,7 +0,0 @@
- A simple task
x A simple completed task
- c2018-12-13 A simple task with creation date
s2018-12-20 d2018-12-24 A task with start date
-2018-12-20 d2018-12-24 A task with alternate start date

28
todo.txt
View file

@ -1,23 +1,7 @@
x2018-10-23 c2018-09-18 Clean up file (adding creation/completion dates) - c2018-09-18 Offer "retry" or "quit" +dialogue - couldn't load from todo file
- c2018-09-18 Offer "retry" or "quit" +dialogue - couldn't save to todo file
- c2018-09-18 Offer "retry" or "quit" +dialogue - syntax error in todo file
- c2018-09-18 Offer to clean up file when loading (adding creation/completion dates)
- c2018-09-18 Purge - move completed tasks to a separate file - c2018-09-18 Purge - move completed tasks to a separate file
x2018-10-23 c2018-09-28 Move cursor to beginning of task description when editing tasks - c2018-09-18 Quit using Esc or q
x2018-10-24 c2018-09-28 Syntax highlighting while editing tasks - c2018-09-18 Sort tasks by completion, priority, due date, description
x2018-10-23 c2018-09-30 Display "-empty-" when TaskList is empty
x2018-09-27 c2018-09-18 Quit using Esc or q
x2018-09-29 c2018-09-28 Use B.EventM's MonadIO instance instead of B.suspendAndResume (facepalm)
x2018-09-30 c2018-09-18 Offer "retry" or "quit" +dialogue - couldn't load from todo file
x2018-09-30 c2018-09-18 Offer "retry" or "quit" +dialogue - couldn't save to todo file
x2018-09-30 c2018-09-18 Offer "retry" or "quit" +dialogue - syntax error in todo file
x2018-09-30 c2018-09-30 Custom exception messages
x2018-10-24 c2018-10-23 Don't crash on parse errors etc.
- c2018-10-24 Fix date coloring in editor
x2018-10-24 c2018-10-24 Reverse ordering of completed tasks - most recent at the top
- c2018-10-24 F1 - list keybindings
- c2018-10-26 Add Z - undo (also Ctrl + Z)
- c2018-10-26 Add Y - redo (also Ctrl + Y)
- c2018-10-26 Implement date expressions using GADTs
- c2018-10-26 Move C - cleanup to F - fixup
- c2018-10-26 Add "starting" task type (start date, prio, due date, description)
- c2018-10-26 Add "formula" task type (formula, prio, due date, description) - maybe due date formula?
x2018-11-01 (D) c2018-10-26 Fix crash on attempting to open a folder
- c2018-10-26 Think of something to do with +project tags, @context tags and key:value tags