From cad2f5741f40acbfd665d9bd626f7162ed8a00a0 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 30 Sep 2018 17:35:57 +0000 Subject: [PATCH] Load and save tasks This commit includes new popups and proper error messages. --- app/Main.hs | 3 +- src/TaskMachine/LTask.hs | 47 +++++++++++++++++++++++----- src/TaskMachine/UI.hs | 31 ++++++++++++++----- src/TaskMachine/UI/Behaviors.hs | 8 ++--- src/TaskMachine/UI/Popup.hs | 37 ++++++++++++---------- src/TaskMachine/UI/Stuff.hs | 54 +++++++++++++++++++++++++++++++++ src/TaskMachine/UI/Types.hs | 28 +++-------------- todo.txt | 9 +++--- 8 files changed, 152 insertions(+), 65 deletions(-) create mode 100644 src/TaskMachine/UI/Stuff.hs diff --git a/app/Main.hs b/app/Main.hs index e67a0d9..ad32d25 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,5 +10,4 @@ import TaskMachine.UI main :: IO() main = do o <- parseOptions - state <- loadTasks $ startUIState o - void $ B.defaultMain myApp state + void $ B.defaultMain myApp $ startUIState o diff --git a/src/TaskMachine/LTask.hs b/src/TaskMachine/LTask.hs index 1ad58a7..9045b57 100644 --- a/src/TaskMachine/LTask.hs +++ b/src/TaskMachine/LTask.hs @@ -20,10 +20,12 @@ module TaskMachine.LTask , saveLTasks ) where +import Control.Exception import Data.Function import Data.List +import System.IO.Error -import qualified Data.Vector as V +import qualified Data.Vector as V import Text.Megaparsec import TaskMachine.Task @@ -54,14 +56,45 @@ modifyLTask f (LTask pos task) = LTask pos (f task) sortLTasks :: [LTask] -> [LTask] sortLTasks = sortBy (compare `on` lPosition) +{- Loading -} + +data ErrorAction + = ErrorMessage String + | IgnoreError + deriving (Show) + +loadErrorMessage :: IOError -> Maybe ErrorAction +loadErrorMessage e + | isDoesNotExistError e = Just IgnoreError + | isIllegalOperation e = Just $ ErrorMessage $ "Could not open file:\n" ++ show e + | isPermissionError e = Just $ ErrorMessage "Could not open file: Permission denied" + | otherwise = Nothing + loadLTasks :: FilePath -> IO (Either String (V.Vector LTask)) loadLTasks file = do - content <- readFile file - case parse pTasks file content of - Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList - Left parseError -> pure $ Left $ parseErrorPretty parseError + content <- tryJust loadErrorMessage $ readFile file + case parse pTasks file <$> content of + Left IgnoreError -> pure $ Right V.empty + Left (ErrorMessage msg) -> pure $ Left msg + Right (Left parseError) -> pure $ Left $ parseErrorPretty parseError + Right (Right taskList) -> pure $ Right $ V.fromList $ fromTasks taskList + --Left parseError -> pure $ Left $ parseErrorPretty parseError + --Right taskList -> pure $ Right $ V.fromList $ fromTasks taskList -saveLTasks :: FilePath -> V.Vector LTask -> IO () +{- Saving -} + +saveErrorMessage :: IOError -> Maybe String +saveErrorMessage e + | isAlreadyInUseError e = Just "Could not save to file: File already in use" + | isFullError e = Just "Could not save to file: Disk full" + | isIllegalOperation e = Just $ "Could not save to file:\n" ++ show e + | isPermissionError e = Just "Could not save to file: Permission denied" + | otherwise = Nothing + +saveLTasks :: FilePath -> V.Vector LTask -> IO (Either String ()) saveLTasks file ltasks = do let text = formatTasks $ toTasks $ V.toList ltasks - writeFile file text + result <- tryJust saveErrorMessage $ writeFile file text + case result of + Left ioErrorMessage -> pure $ Left ioErrorMessage + Right _ -> pure $ Right () diff --git a/src/TaskMachine/UI.hs b/src/TaskMachine/UI.hs index 12a13bf..3a935d9 100644 --- a/src/TaskMachine/UI.hs +++ b/src/TaskMachine/UI.hs @@ -1,16 +1,18 @@ module TaskMachine.UI ( myApp , startUIState - , loadTasks ) where import qualified Brick as B import qualified Brick.Themes as B +import Control.Monad.Trans import qualified Data.Vector as V import qualified Graphics.Vty.Input.Events as VTY import TaskMachine.Options import TaskMachine.UI.Behaviors +import TaskMachine.UI.Popup +import TaskMachine.UI.Stuff import TaskMachine.UI.TaskList import TaskMachine.UI.Types @@ -20,7 +22,7 @@ drawTaskList :: UIState -> B.Widget RName drawTaskList s = renderTaskList (taskEdit s) True (tasks s) drawUIState :: UIState -> [B.Widget RName] ---drawUIState s@UIState{errorPopup=Just p} = [renderPopupOk p, drawTaskList s] +drawUIState s@UIState{errorPopup=Just p} = [renderPopup p, drawTaskList s] drawUIState s = [drawTaskList s] {- Updating the state -} @@ -30,9 +32,19 @@ 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 +popupBehavior :: Popup RName (UIState -> NewState) -> UIState -> VTY.Event -> NewState +popupBehavior p s (VTY.EvKey VTY.KEnter []) = + case popupSelection p of + Nothing -> B.continue s{errorPopup=Nothing} + Just action -> do + action s{errorPopup=Nothing} +popupBehavior p s e = do + newPopup <- handlePopupEvent e p + B.continue s{errorPopup=Just newPopup} + 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 = popupBehavior p s e -- Under the assumption that tasks can only be edited while the task list is focused, edit a task selectBehavior s@UIState{taskEdit=Just edit} e = taskEditBehavior edit s e -- If nothing immediately jumps out at you, see which part has focus. @@ -44,19 +56,22 @@ updateUIState s _ = B.continue s {- Starting the app -} +startEvent :: UIState -> B.EventM RName UIState +startEvent = liftIO . loadTasks + myApp :: B.App UIState () RName myApp = B.App { B.appDraw = drawUIState , B.appChooseCursor = B.showFirstCursor , B.appHandleEvent = updateUIState - , B.appStartEvent = pure + , B.appStartEvent = startEvent , B.appAttrMap = const (B.themeToAttrMap defaultTheme) } startUIState :: Options -> UIState startUIState o = UIState - { options = o - --, errorPopup = Nothing - , tasks = taskList RTaskList V.empty - , taskEdit = Nothing + { options = o + , errorPopup = Nothing + , tasks = taskList RTaskList V.empty + , taskEdit = Nothing } diff --git a/src/TaskMachine/UI/Behaviors.hs b/src/TaskMachine/UI/Behaviors.hs index 5a76d7a..ccc56bb 100644 --- a/src/TaskMachine/UI/Behaviors.hs +++ b/src/TaskMachine/UI/Behaviors.hs @@ -13,6 +13,7 @@ import Text.Megaparsec import TaskMachine.Task import TaskMachine.UI.TaskList import TaskMachine.UI.Types +import TaskMachine.UI.Stuff startEdit :: UIState -> UIState startEdit s = @@ -36,8 +37,7 @@ taskEditBehavior _ s (VTY.EvKey VTY.KEsc []) = B.continue s{taskEdit=Nothin taskEditBehavior edit s (VTY.EvKey VTY.KHome []) = B.continue s{taskEdit=Just (B.applyEdit T.gotoBOL edit)} taskEditBehavior edit s (VTY.EvKey VTY.KEnd []) = B.continue s{taskEdit=Just (B.applyEdit T.gotoEOL edit)} taskEditBehavior edit s (VTY.EvKey VTY.KEnter []) = do - let newState = finishEdit edit s - liftIO $ saveTasks newState + newState <- liftIO $ saveTasks $ finishEdit edit s B.continue newState taskEditBehavior edit s e = do newEdit <- B.handleEditorEvent e edit @@ -45,9 +45,7 @@ taskEditBehavior edit s e = do taskListBehavior :: UIState -> VTY.Event -> NewState -- Reload while running -taskListBehavior s (VTY.EvKey (VTY.KChar 'r') []) = do - newState <- liftIO $ loadTasks s - B.continue newState +taskListBehavior s (VTY.EvKey (VTY.KChar 'r') []) = actionLoad s -- Mark/unmark a task as completed taskListBehavior s (VTY.EvKey (VTY.KChar 'x') []) = undefined s -- Delete tasks diff --git a/src/TaskMachine/UI/Popup.hs b/src/TaskMachine/UI/Popup.hs index 219e355..dab846c 100644 --- a/src/TaskMachine/UI/Popup.hs +++ b/src/TaskMachine/UI/Popup.hs @@ -1,11 +1,12 @@ module TaskMachine.UI.Popup ( minPopupWidth -- * Ok popup - , PopupOk - , popupOk - , popupOk' - , renderPopupOk - , handlePopupOkEvent + , Popup + , popup + , popup' + , renderPopup + , handlePopupEvent + , popupSelection ) where import qualified Brick as B @@ -17,18 +18,22 @@ minPopupWidth = 78 {- Ok popup -} -data PopupOk n = PopupOk (B.Dialog ()) (B.Widget n) +data Popup n r = Popup (B.Dialog r) (B.Widget n) -popupOk :: String -> String -> PopupOk n -popupOk title content = popupOk' title (B.str content) +popup :: String -> String -> [(String, r)] -> Popup n r +popup title content = popup' 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 +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 -renderPopupOk :: PopupOk n -> B.Widget n -renderPopupOk (PopupOk dialog widget) = B.renderDialog dialog widget +renderPopup :: Popup n r -> B.Widget n +renderPopup (Popup 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 +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 diff --git a/src/TaskMachine/UI/Stuff.hs b/src/TaskMachine/UI/Stuff.hs new file mode 100644 index 0000000..75c85c5 --- /dev/null +++ b/src/TaskMachine/UI/Stuff.hs @@ -0,0 +1,54 @@ +module TaskMachine.UI.Stuff where + +import qualified Brick as B +import Control.Monad.Trans + +import TaskMachine.LTask +import TaskMachine.Options +import TaskMachine.UI.Popup +import TaskMachine.UI.TaskList +import TaskMachine.UI.Types + +actionQuit :: UIState -> NewState +actionQuit = B.halt + +actionDoNothing :: UIState -> NewState +actionDoNothing = B.continue + +actionLoad :: UIState -> NewState +actionLoad s = do + state <- liftIO $ loadTasks s + B.continue state + +loadTasks :: UIState -> IO UIState +loadTasks s = do + let file = oTodofile $ options s + result <- loadLTasks file + case result of + Right ltasks -> pure s{tasks=taskList RTaskList ltasks} + Left errorMessage -> + let p = popup "Error loading tasks" errorMessage + [ ("Retry", actionLoad) + , ("Quit", actionQuit) + ] + in pure s{errorPopup=Just p} + +actionSave :: UIState -> NewState +actionSave s = do + state <- liftIO $ saveTasks s + B.continue state + +saveTasks :: UIState -> IO UIState +saveTasks s = do + let filepath = oTodofile (options s) + ltasks = taskListElements (tasks s) + result <- saveLTasks filepath ltasks + case result of + Right _ -> pure s + Left errorMessage -> + let p = popup "Error saving tasks" errorMessage + [ ("Retry", actionSave) + , ("Continue without saving", actionDoNothing) + , ("Quit", actionQuit) + ] + in pure s{errorPopup=Just p} diff --git a/src/TaskMachine/UI/Types.hs b/src/TaskMachine/UI/Types.hs index 7500ea7..6a313f7 100644 --- a/src/TaskMachine/UI/Types.hs +++ b/src/TaskMachine/UI/Types.hs @@ -10,8 +10,6 @@ module TaskMachine.UI.Types , UIState(..) , NewState , defaultTheme - , loadTasks - , saveTasks ) where import qualified Brick as B @@ -21,8 +19,8 @@ import qualified Brick.Widgets.Edit as B import qualified Brick.Widgets.List as B import qualified Graphics.Vty as VTY -import TaskMachine.LTask import TaskMachine.Options +import TaskMachine.UI.Popup import TaskMachine.UI.Task import TaskMachine.UI.TaskList @@ -35,10 +33,10 @@ data RName {- UI state -} data UIState = UIState - { options :: Options -- includes todo file and other config - --, errorPopup :: Maybe (PopupOk RName) - , tasks :: TaskList RName - , taskEdit :: Maybe (B.Editor String RName) + { options :: Options -- includes todo file and other config + , errorPopup :: Maybe (Popup RName (UIState -> NewState)) + , tasks :: TaskList RName + , taskEdit :: Maybe (B.Editor String RName) } type NewState = B.EventM RName (B.Next UIState) @@ -73,19 +71,3 @@ defaultTheme = B.newTheme VTY.defAttr bg' = VTY.withBackColor none st' = VTY.withStyle none none = VTY.defAttr - -loadTasks :: UIState -> IO UIState -loadTasks s = do - let file = oTodofile $ options s - result <- loadLTasks file - case result of - -- TODO: Improve error handling when loading files - --Left errorMessage -> pure s{errorPopup=Just $ popupOk "Error loading tasks" errorMessage} - Left errorMessage -> undefined errorMessage - Right ltasks -> pure s{tasks=taskList RTaskList ltasks} - -saveTasks :: UIState -> IO () -saveTasks s = do - let filepath = oTodofile (options s) - ltasks = taskListElements (tasks s) - saveLTasks filepath ltasks diff --git a/todo.txt b/todo.txt index 4cb4270..ad3d01f 100644 --- a/todo.txt +++ b/todo.txt @@ -1,10 +1,11 @@ -- 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 Sort tasks by completion, priority, due date, description - c2018-09-28 Move cursor to beginning of task description when editing tasks - c2018-09-28 Syntax highlighting while editing tasks +- c2018-09-30 Sort tasks when (re-)loading 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