From 133b0ca9ed84d8b0e519c32ffe4598ae1e67d7bb Mon Sep 17 00:00:00 2001 From: Joscha Date: Mon, 17 Sep 2018 16:21:26 +0000 Subject: [PATCH] Add basic task editing --- package.yaml | 1 + src/TaskMachine/LTask.hs | 6 +-- src/TaskMachine/Todotxt.hs | 55 ++++++++++++---------- src/TaskMachine/UI.hs | 23 +++++---- src/TaskMachine/UI/TaskList.hs | 86 ++++++++++++++++++++++++++-------- src/TaskMachine/UI/TopBar.hs | 2 +- src/TaskMachine/UI/Types.hs | 52 ++++++++++++++++---- 7 files changed, 156 insertions(+), 69 deletions(-) diff --git a/package.yaml b/package.yaml index 47e936c..95ca558 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ dependencies: - containers - megaparsec - optparse-applicative +- text-zipper - time - vector - vty diff --git a/src/TaskMachine/LTask.hs b/src/TaskMachine/LTask.hs index fa6998c..10ecc98 100644 --- a/src/TaskMachine/LTask.hs +++ b/src/TaskMachine/LTask.hs @@ -7,8 +7,8 @@ module TaskMachine.LTask , saveLTasks ) where -import Data.List -import Data.Function +import Data.Function +import Data.List import qualified Data.Vector as V @@ -29,7 +29,7 @@ loadLTasks :: FilePath -> IO (Either String (V.Vector LTask)) loadLTasks file = do content <- readFile file case parseTasks file content of - Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList + Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList Left parseError -> pure $ Left $ show parseError saveLTasks :: V.Vector LTask -> FilePath -> IO () diff --git a/src/TaskMachine/Todotxt.hs b/src/TaskMachine/Todotxt.hs index 750ab2c..6145d3d 100644 --- a/src/TaskMachine/Todotxt.hs +++ b/src/TaskMachine/Todotxt.hs @@ -16,19 +16,22 @@ module TaskMachine.Todotxt , charToPriority -- * Parsing , Parser - , task - , tasks - , day - , dates - , priorityChar - , priority + , pTask + , pTasks + , pDay + , pDates + , pPriorityChar + , pPriority + , andSpace + , maybeParse + , untilEndOfLine ) where import Control.Monad import Data.List.NonEmpty import Data.Void -import Data.Set as Set +import Data.Set as Set import Data.Time.Calendar import Text.Megaparsec import Text.Megaparsec.Char @@ -48,8 +51,8 @@ formatDates (CoCrDate cr co) = show cr ++ " " ++ show co {- Dates parsing -} -day :: Parser Day -day = label "date" $ fromGregorian +pDay :: Parser Day +pDay = label "date" $ fromGregorian <$> integer <*> (char '-' *> int) <*> (char '-' *> int) @@ -59,13 +62,13 @@ day = label "date" $ fromGregorian int :: Parser Int int = read <$> count 2 digitChar -dates :: Parser Dates -dates = try datesCrCo <|> datesCr +pDates :: Parser Dates +pDates = try datesCrCo <|> datesCr where datesCrCo :: Parser Dates - datesCrCo = CoCrDate <$> (day <* char ' ') <*> day + datesCrCo = CoCrDate <$> (pDay <* char ' ') <*> pDay datesCr :: Parser Dates - datesCr = CrDate <$> day + datesCr = CrDate <$> pDay {- Priority -} @@ -93,16 +96,16 @@ formatPriority p = '(' : priorityToChar p : ")" {- Priority parsing -} -priorityChar :: Parser Priority -priorityChar = do +pPriorityChar :: Parser Priority +pPriorityChar = do c <- anyChar case charToPriority c of Just p -> pure p Nothing -> failure (Just $ Tokens $ c :| []) (Set.singleton $ Label $ 'p' :| "riority character") -priority :: Parser Priority -priority = char '(' *> priorityChar <* char ')' +pPriority :: Parser Priority +pPriority = char '(' *> pPriorityChar <* char ')' {- Task -} @@ -118,14 +121,14 @@ data Task = Task -- show = formatTask formatTask :: Task -> String -formatTask (Task done prio tDates desc) +formatTask (Task done prio dates desc) = (if done then "x " else "") ++ maybe "" ((++" ") . formatPriority) prio - ++ maybe "" ((++" ") . formatDates) tDates + ++ maybe "" ((++" ") . formatDates) dates ++ desc parseTasks :: FilePath -> String -> Either (ParseError Char Void) [Task] -parseTasks = parse tasks -- hehe +parseTasks = parse pTasks -- hehe {- Task parsing -} @@ -144,12 +147,12 @@ maybeParse p = (Just <$> try p) <|> pure Nothing untilEndOfLine :: Parser String untilEndOfLine = takeWhile1P (Just "description") (/='\n') -task :: Parser Task -task = Task +pTask :: Parser Task +pTask = Task <$> boolParse (andSpace completed) - <*> maybeParse (andSpace priority) - <*> maybeParse (andSpace dates) + <*> maybeParse (andSpace pPriority) + <*> maybeParse (andSpace pDates) <*> untilEndOfLine -tasks :: Parser [Task] -tasks = many $ task <* (eof <|> void (char '\n')) +pTasks :: Parser [Task] +pTasks = many $ pTask <* (eof <|> void (char '\n')) diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs index 3c1c2a1..bf69f21 100644 --- a/src/TaskMachine/UI.hs +++ b/src/TaskMachine/UI.hs @@ -44,21 +44,24 @@ Edit _____________________________ -- * warn if file only readable -- [_] display loaded tasks in UI +drawBaseLayer :: UIState -> B.Widget RName +drawBaseLayer s = B.vBox [placeholderTopBar, renderTaskList s, placeholderNewTask] + drawUIState :: UIState -> [B.Widget RName] -drawUIState s = - let wTopBar = const placeholderTopBar - wTaskList = renderTaskList (taskList s) (taskEdit s) - wNewTask = const placeholderNewTask - in pure $ case B.focusGetCurrent (focus s) of - Nothing -> B.vBox [wTopBar False, wTaskList False, wNewTask False] -- should never happen - (Just BRTopBar) -> B.vBox [wTopBar True, wTaskList False, wNewTask False] - (Just BRTaskList) -> B.vBox [wTopBar False, wTaskList True, wNewTask False] - (Just BRNewTask) -> B.vBox [wTopBar False, wTaskList False, wNewTask True ] +drawUIState s@UIState{errorPopup=Just p} = [renderPopup p, drawBaseLayer s] +drawUIState s = [drawBaseLayer s] updateUIState :: UIState -> B.BrickEvent RName () -> B.EventM RName (B.Next UIState) +-- Closing any popups +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} +-- If there's no password updateUIState s e = case B.focusGetCurrent (focus s) of - Nothing -> undefined + Nothing -> B.halt s (Just BRTopBar) -> placeholderUpdate s e (Just BRTaskList) -> updateTaskList s e (Just BRNewTask) -> placeholderUpdate s e diff --git a/src/TaskMachine/UI/TaskList.hs b/src/TaskMachine/UI/TaskList.hs index 37f99b6..e724698 100644 --- a/src/TaskMachine/UI/TaskList.hs +++ b/src/TaskMachine/UI/TaskList.hs @@ -1,12 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module TaskMachine.UI.TaskList where +import Data.Void + import qualified Brick as B +import qualified Brick.Focus as B import qualified Brick.Widgets.Edit as B import qualified Brick.Widgets.List as B -import qualified Graphics.Vty as VTY +import qualified Data.Text.Zipper as T +import qualified Graphics.Vty as VTY +import Text.Megaparsec import TaskMachine.LTask import TaskMachine.Todotxt @@ -40,28 +44,73 @@ renderLTask highlight (LTask _ Task{..}) = {- Rendering -} renderLTask :: Maybe (B.Editor String RName) -> Bool -> LTask -> B.Widget RName -renderLTask _ False (LTask _ t) = B.withAttr "normal" $ B.str $ formatTask t -renderLTask Nothing True (LTask _ t) = B.withAttr "highlight" $ B.str $ formatTask t -renderLTask (Just edit) True _ = B.withAttr "highlight" $ B.renderEditor (B.str . unlines) True edit +renderLTask _ False (LTask _ t) = B.str $ formatTask t +renderLTask Nothing True (LTask _ t) = B.str $ formatTask t +renderLTask (Just edit) True _ = B.renderEditor (B.str . unlines) True edit -renderTaskList :: B.List RName LTask -> Maybe (B.Editor String RName) -> Bool -> B.Widget RName -renderTaskList taskList edit focus = B.renderList (renderLTask edit) focus taskList +renderTaskList :: UIState -> B.Widget RName +renderTaskList s = + let inFocus = B.focusGetCurrent (focus s) == Just BRTaskList + in B.renderList (renderLTask (taskEdit s)) inFocus (taskList s) + +{- Editing tasks -} + +toEditText :: Task -> String +toEditText Task{taskPriority=Nothing, taskDescription=d} = d +toEditText Task{taskPriority=Just p, taskDescription=d} = formatPriority p ++ " " ++ d + +pEditText :: Parser (Maybe Priority, String) +pEditText = (,) <$> maybeParse (andSpace pPriority) <*> untilEndOfLine + +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} + 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 +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') [])) = - case B.listSelectedElement (taskList s) of - Nothing -> B.continue s - Just (_, (LTask _ t)) -> - let edit = B.editor RTaskEdit (Just 1) ("- editor test -" ++ formatTask t) - in B.continue s{taskEdit=Just edit} +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) @@ -69,14 +118,11 @@ updateTaskList s@UIState{taskEdit=Nothing} (B.VtyEvent e) = do -- 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 [])) = do - let changeTask (LTask n t) = LTask n t{taskDescription="hehe, changed"} - newList = B.listModify changeTask (taskList s) - B.continue s{taskList=newList, taskEdit=Nothing} +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 - newEdit <- B.handleEditorEvent e edit - B.continue s{taskEdit=Just newEdit} + 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 index 9a4a6c7..16c708f 100644 --- a/src/TaskMachine/UI/TopBar.hs +++ b/src/TaskMachine/UI/TopBar.hs @@ -1,6 +1,6 @@ module TaskMachine.UI.TopBar where -import qualified Brick as B +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 index 9063568..4256d23 100644 --- a/src/TaskMachine/UI/Types.hs +++ b/src/TaskMachine/UI/Types.hs @@ -8,6 +8,12 @@ module TaskMachine.UI.Types ( RName(..) , BigRing(..) , SmallRing(..) + -- * Popups + , Popup + , popup + , renderPopup + , handlePopupEvent + -- * UI state , UIState(..) , startUIState , bigFocusNext, bigFocusPrev @@ -15,12 +21,14 @@ module TaskMachine.UI.Types , defaultTheme ) where -import qualified Brick.Focus as B -import qualified Brick.Themes as B -import qualified Brick.Widgets.List as B -import qualified Brick.Widgets.Edit as B -import qualified Data.Vector as V -import qualified Graphics.Vty as VTY +import qualified Brick as B +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 @@ -44,12 +52,31 @@ data SmallRing | 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 -} + -- | The state of the program and UI data UIState = 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 @@ -73,6 +100,7 @@ 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 @@ -94,14 +122,20 @@ smallFocusPrev s = s{focusTopBar=B.focusPrev (focusTopBar s)} defaultTheme :: B.Theme defaultTheme = B.newTheme VTY.defAttr - [ ("normal" , none) - , ("normal" <> "description", none) + [ (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) + , ("normal" , none) , ("normal" <> "priority", fg VTY.cyan $ st' VTY.bold) , ("normal" <> "priority" <> "A", fg VTY.red $ st' VTY.bold) , ("normal" <> "priority" <> "B", fg VTY.yellow $ st' VTY.bold) , ("normal" <> "priority" <> "C", fg VTY.green $ st' VTY.bold) , ("highlight", bg' VTY.blue) - , ("highlight" <> "description", bg' VTY.blue) , ("highlight" <> "priority", bg VTY.blue $ fg VTY.cyan $ st' VTY.bold) , ("highlight" <> "priority" <> "A", bg VTY.blue $ fg VTY.red $ st' VTY.bold) , ("highlight" <> "priority" <> "B", bg VTY.blue $ fg VTY.yellow $ st' VTY.bold)