test5: use ExceptT for editTagsAtCursor

1 files changed, 80 insertions, 78 deletions

diff --git a/test5.hs b/test5.hs
index c6b83bd..5ee6ea8 100644
--- a/test5.hs
+++ b/test5.hs
@@ -267,7 +267,7 @@ keymap "&" = toggleTagAtCursor "killed"
 keymap "*" = toggleTagAtCursor "star"
 keymap "r" = replyToAll
 keymap "e" = viewSource
-keymap "t" = editTags
+keymap "t" = editTagsAtCursor
 keymap "k" = moveCursorUp 1
 keymap "j" = moveCursorDown 1
 keymap "K" = moveTreeDown 1
@@ -636,6 +636,13 @@ editMailE ps =
         Left code -> throwE $ "edit mail error: " ++ show code
 
 
+editTagsE :: [Tag] -> ExceptT String IO [TagOp]
+editTagsE ps =
+    liftE (editTags ps) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "edit tags error: " ++ show code
+
+
 viewMailE :: String -> ExceptT String IO ()
 viewMailE ps =
     liftE (viewMail ps) >>= \case
@@ -730,84 +737,67 @@ viewSource q0 =
         liftE (readFile $ Notmuch.messageFilename msg) >>= viewMailE
 
 
--- TODO editTags is too convoluted
-editTags :: State -> IO State
-editTags q@State{..} = case Z.label cursor of
-    TVSearchResult sr -> do
-        edit
-            (Notmuch.searchTags sr)
-            (Notmuch.unThreadID $ Notmuch.searchThread sr)
-            (\tagOps loc ->
-                Z.modifyTree (patchTreeTags tagOps) loc
-            )
-
-    TVMessage m -> do
-        edit
-            (Notmuch.messageTags m)
-            (Notmuch.unMessageID $ Notmuch.messageId m) -- TODO describe war besser
-            (\tagOps mloc ->
-                -- TODO this needs test cases
-                let
-                    -- patch message
-                    mloc' = Z.modifyTree (patchRootLabelTags tagOps) mloc
-
-                    -- find search result of message
-                    srloc = fromMaybe (error "could not find search result of message")
-                                      (findParent isTVSearchResult mloc')
-
-                    -- patch search result
-                    srloc' = Z.modifyTree (patchRootLabelTags tagOps) srloc
-
-                in
-                  -- return message
-                  fromMaybe (error "could not find message again")
-                            (findTree (==Z.label mloc) srloc')
-                )
-    _ ->
-        return q { flashMessage = "cannot edit tags here" }
+editTagsAtCursor :: State -> IO State
+editTagsAtCursor q0 =
+    runExceptT (go q0) >>= return . \case
+        Right q' -> q'
+        Left err -> q0 { flashMessage = Plain $ "error: " ++ show err }
   where
-    edit tags query patch = do
-        withTempFile' ".tags" $ \(path, draftH) -> do
-            hPutStr stdout "\ESC[?1049h" -- TODO geht besser
-            hPutStr stdout "\ESC[?25l" -- TODO war mal besser
-            setFileMode path 0o600
-
-            -- generate draft
-            T.hPutStrLn draftH $ T.intercalate " " tags
-            hPutStrLn draftH $ "# " <> query
-
-            hClose draftH
-
-            runEditor' path q >>= \case
-                ExitFailure code -> do
-                    return q { flashMessage = Plain $ "editor exit code = " ++ show code }
-                ExitSuccess -> do
-                    -- TODO parse could fail
-                    tags' <- parseTags <$> readFile path
-
-                    case diffTags tags tags' of
-                        [] ->
-                            return q { flashMessage = Plain "nothing happened" } -- TODO highlight
-                        tagOps -> do
-                            (_, _, _, procH) <-
-                                withFile "/dev/null" ReadWriteMode $ \nullH ->
-                                    -- TODO batch tagging(?)
-                                    -- TODO proper type for query
-                                    createProcess
-                                        (proc "notmuch" $ [ "tag" ] ++ tagOpsToArgs tagOps ++ [ "--", query ])
-                                            { std_in = UseHandle nullH
-                                            , std_out = UseHandle nullH
-                                            }
-                            waitForProcess procH >>= \case
-                                ExitFailure code ->
-                                    return q { flashMessage = Plain $ "notmuch exit code = " ++ show code }
-                                ExitSuccess ->
-                                    return q { cursor = select (==Z.label cursor) (patch tagOps cursor) }
-
-    -- TODO DRY select
-    select p loc =
-        let root = Z.root loc
-        in fromMaybe root $ findTree p root
+    go :: State -> ExceptT String IO State
+    go q@State{..} = do
+        -- TODO does this scream for a type class? :)
+        (searchTerm, tags, patch) <- case Z.label cursor of
+            TVSearchResult sr -> return
+                ( Notmuch.unThreadID $ Notmuch.searchThread sr
+                , Notmuch.searchTags sr
+                , patchSearchResult
+                )
+            TVMessage m -> return
+                ( Notmuch.unMessageID $ Notmuch.messageId m
+                , Notmuch.messageTags m
+                , patchMessage
+                )
+            _ -> throwE "cannot edit tags here"
+
+        tagOps <- editTagsE tags
+        when (null tagOps) (throwE "nothing happened")
+
+        _ <- readNotmuchE ("tag" : tagOpsToArgs tagOps ++ ["--", searchTerm]) ""
+
+        return q { cursor = select (==Z.label cursor) (patch tagOps cursor) }
+
+
+patchMessage
+    :: [TagOp] -> Z.TreePos Z.Full TreeView -> Z.TreePos Z.Full TreeView
+patchMessage tagOps loc =
+    Z.modifyTree (patchTreeTags tagOps) loc
+
+
+patchSearchResult
+     :: [TagOp] -> Z.TreePos Z.Full TreeView -> Z.TreePos Z.Full TreeView
+patchSearchResult tagOps loc =
+    -- TODO this needs test cases
+    let
+        -- patch message
+        loc' = Z.modifyTree (patchRootLabelTags tagOps) loc
+
+        -- find search result of message
+        srloc = fromMaybe (error "could not find search result of message")
+                          (findParent isTVSearchResult loc')
+
+        -- patch search result
+        srloc' = Z.modifyTree (patchRootLabelTags tagOps) srloc
+    in
+        -- return message
+        fromMaybe (error "could not find message again")
+                  (findTree (==Z.label loc) srloc')
+
+
+-- TODO rename select
+select :: (a -> Bool) -> Z.TreePos Z.Full a -> Z.TreePos Z.Full a
+select p loc =
+    let root = Z.root loc
+    in fromMaybe root $ findTree p root
 
 
 editString :: State -> String -> IO (Either String String)
@@ -873,6 +863,18 @@ editMail s =
             code -> return (Left code)
 
 
+editTags :: [Tag] -> IO (Either ExitCode [TagOp])
+editTags tags =
+    withTempFile' "edit.tags" $ \(path, h_tempFile) -> do
+        T.hPutStrLn h_tempFile $ T.intercalate " " tags
+        hClose h_tempFile
+        editor <- getEnv "EDITOR"
+        runInteractive editor [path] >>= \case
+            ExitSuccess -> Right . diffTags tags . parseTags <$> readFile path
+                                                   -- ^ TODO parseTags can fail
+            code -> return (Left code)
+
+
 viewMail :: String -> IO (Either ExitCode ())
 viewMail s = do
     pager <- getEnv "PAGER"