Action: init

2 files changed, 185 insertions, 171 deletions

diff --git a/Action.hs b/Action.hs
new file mode 100644
index 0000000..219246c
--- /dev/null
+++ b/Action.hs
@@ -0,0 +1,184 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Action where
+
+import Blessings.String
+import State
+import TagUtils
+import TreeSearch
+import TreeView
+import TreeZipperUtils
+import qualified Data.Tree as Tree
+import qualified Data.Tree.Zipper as Z
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+
+defaultMouse1Click :: Monad m => Int -> State -> m State
+defaultMouse1Click y q@State{..} = do
+    let linearClickPos =
+            let i = (y - length headBuffer + yoffset) - 1 {-zero-based-}
+            in if 0 <= i && i < length treeBuffer
+                then Just i
+                else Nothing
+    case linearClickPos of
+        Nothing ->
+            return q
+                { flashMessage = Plain "nothing to click"
+                }
+        Just i ->
+            return q
+                { cursor = findNextN i $ Z.root cursor
+                }
+
+
+moveCursorDown :: Monad m => Int -> State -> m State
+moveCursorDown n q@State{..} =
+    let cursor' = findNextN n cursor
+        q' = q { cursor = cursor' }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveTreeUp i q'
+
+
+moveCursorUp :: Monad m => Int -> State -> m State
+moveCursorUp n q@State{..} =
+    let cursor' = findPrevN n cursor
+        q' = q { cursor = cursor' }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveTreeDown i q'
+
+
+moveTreeUp :: Monad m => Int -> State -> m State
+moveTreeUp n q@State{..} =
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveCursorDown i q'
+
+
+moveTreeDown :: Monad m => Int -> State -> m State
+moveTreeDown n q@State{..} =
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveCursorUp i q'
+
+
+moveTreeLeft :: Monad m => Int -> State -> m State
+moveTreeLeft n q@State{..} =
+    return q { xoffset = xoffset + n }
+
+moveTreeRight :: Monad m => Int -> State -> m State
+moveTreeRight n q@State{..} =
+    return q { xoffset = max 0 (xoffset - n) }
+
+
+moveToParent :: Monad m => State -> m State
+moveToParent q@State{..} =
+    case Z.parent cursor of
+        Nothing -> return q { flashMessage = "cannot go further up" }
+        Just cursor' ->
+            let q' = q { cursor = cursor' }
+            in case topOverrun q' of
+                0 -> return q'
+                i -> moveTreeDown i q'
+
+
+moveCursorToUnread
+    :: (Num a, Monad m, Eq a)
+    => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView))
+    -> (State -> a)
+    -> (a -> State -> m State)
+    -> State -> m State
+moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} =
+    case cursorMove cursor >>= rec of
+        Just cursor' ->
+            let q' = q { cursor = cursor' }
+            in case getTreeMoveCount q' of
+                0 -> return q'
+                i -> treeMove i q'
+        Nothing ->
+            return q { flashMessage = "no unread message in sight" }
+  where
+    rec loc =
+        if hasTag "unread" loc
+            then Just loc
+            else cursorMove loc >>= rec
+    hasTag tag loc =
+        case Z.label loc of
+            TVSearchResult sr ->
+                tag `elem` Notmuch.searchTags sr
+            TVMessage m ->
+                tag `elem` Notmuch.messageTags m
+            _ ->
+                False
+
+moveCursorUpToPrevUnread :: Monad m => State -> m State
+moveCursorUpToPrevUnread =
+    moveCursorToUnread findPrev topOverrun moveTreeDown
+
+moveCursorDownToNextUnread :: Monad m => State -> m State
+moveCursorDownToNextUnread =
+    moveCursorToUnread findNext botOverrun moveTreeUp
+
+
+toggleFold :: State -> IO State
+toggleFold q@State{..} =
+    getNewSubForest >>= return . \case
+        Left err ->
+            q { flashMessage = SGR [31] $ Plain err }
+        Right sf ->
+            q { cursor = Z.modifyTree (setSubForest sf) cursor }
+  where
+    getNewSubForest =
+        if hasUnloadedSubForest (Z.tree cursor)
+            then loadSubForest (Z.label cursor)
+            else return $ Right $ unloadSubForest (Z.tree cursor)
+
+
+toggleTagAtCursor :: Tag -> State -> IO State
+toggleTagAtCursor tag q@State{..} = case Z.label cursor of
+
+    TVSearchResult sr -> do
+        let tagOp =
+                if tag `elem` Notmuch.searchTags sr
+                    then DelTag
+                    else AddTag
+            tagOps = [tagOp tag]
+        Notmuch.notmuchTag tagOps sr
+        let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor
+        return q { cursor = cursor' }
+
+    TVMessage m -> do
+        let tagOp =
+                if tag `elem` Notmuch.messageTags m
+                    then DelTag
+                    else AddTag
+            tagOps = [tagOp tag]
+        Notmuch.notmuchTag tagOps m
+        let cursor' =
+                -- TODO this needs a nice name
+                modifyFirstParentLabelWhere isTVSearchResult f $
+                Z.modifyLabel f cursor
+            f = patchTags tagOps
+        return q { cursor = cursor' }
+
+    _ -> return q { flashMessage = "nothing happened" }
+
+
+topOverrun :: State -> Int
+topOverrun State{..} =
+    max 0 (- (linearPos cursor - yoffset))
+
+
+botOverrun :: State -> Int
+botOverrun State{..} =
+    max 0 (linearPos cursor - yoffset - (screenHeight - (length headBuffer) - 1))
+
+
+setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a
+setSubForest sf t = t { Tree.subForest = sf }
+
diff --git a/test5.hs b/test5.hs
index fc46495..f3012b9 100644
--- a/test5.hs
+++ b/test5.hs
@@ -19,6 +19,7 @@ import qualified Notmuch.SearchResult as Notmuch
 import qualified System.Console.Terminal.Size as Term
 import Blessings.String (Blessings(Plain,SGR),pp)
 import qualified Blessings.Internal as Blessings
+import Action
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
@@ -338,172 +339,6 @@ mousemap info = \q ->
     return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
 
 
-defaultMouse1Click :: Monad m => Int -> State -> m State
-defaultMouse1Click y q@State{..} = do
-    let linearClickPos =
-            let i = (y - length headBuffer + yoffset) - 1 {-zero-based-}
-            in if 0 <= i && i < length treeBuffer
-                then Just i
-                else Nothing
-    case linearClickPos of
-        Nothing ->
-            return q
-                { flashMessage = Plain $ "nothing to click"
-                }
-        Just i ->
-            return q
-                { cursor = findNextN i $ Z.root cursor
-                }
-
-
-
-topOverrun :: State -> Int
-topOverrun State{..} =
-    max 0 (- (linearPos cursor - yoffset))
-
-
-botOverrun :: State -> Int
-botOverrun State{..} =
-    max 0 (linearPos cursor - yoffset - (screenHeight - (length headBuffer) - 1))
-
-
-
-moveCursorDown :: Monad m => Int -> State -> m State
-moveCursorDown n q@State{..} =
-    let cursor' = findNextN n cursor
-        q' = q { cursor = cursor' }
-    in case botOverrun q' of
-        0 -> return q'
-        i -> moveTreeUp i q'
-
-
-moveCursorUp :: Monad m => Int -> State -> m State
-moveCursorUp n q@State{..} =
-    let cursor' = findPrevN n cursor
-        q' = q { cursor = cursor' }
-    in case topOverrun q' of
-        0 -> return q'
-        i -> moveTreeDown i q'
-
-
-moveTreeUp :: Monad m => Int -> State -> m State
-moveTreeUp n q@State{..} =
-    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) }
-    in case topOverrun q' of
-        0 -> return q'
-        i -> moveCursorDown i q'
-
-
-moveTreeDown :: Monad m => Int -> State -> m State
-moveTreeDown n q@State{..} =
-    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) }
-    in case botOverrun q' of
-        0 -> return q'
-        i -> moveCursorUp i q'
-
-
-moveTreeLeft :: Monad m => Int -> State -> m State
-moveTreeLeft n q@State{..} =
-    return q { xoffset = xoffset + n }
-
-moveTreeRight :: Monad m => Int -> State -> m State
-moveTreeRight n q@State{..} =
-    return q { xoffset = max 0 (xoffset - n) }
-
-
-moveToParent :: Monad m => State -> m State
-moveToParent q@State{..} =
-    case Z.parent cursor of
-        Nothing -> return q { flashMessage = "cannot go further up" }
-        Just cursor' ->
-            let q' = q { cursor = cursor' }
-            in case topOverrun q' of
-                0 -> return q'
-                i -> moveTreeDown i q'
-
-
-moveCursorToUnread
-    :: (Num a, Monad m, Eq a)
-    => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView))
-    -> (State -> a)
-    -> (a -> State -> m State)
-    -> State -> m State
-moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} =
-    case cursorMove cursor >>= rec of
-        Just cursor' ->
-            let q' = q { cursor = cursor' }
-            in case getTreeMoveCount q' of
-                0 -> return q'
-                i -> treeMove i q'
-        Nothing ->
-            return q { flashMessage = "no unread message in sight" }
-  where
-    rec loc =
-        if hasTag "unread" loc
-            then Just loc
-            else cursorMove loc >>= rec
-    hasTag tag loc =
-        case Z.label loc of
-            TVSearchResult sr ->
-                tag `elem` Notmuch.searchTags sr
-            TVMessage m ->
-                tag `elem` Notmuch.messageTags m
-            _ ->
-                False
-
-moveCursorUpToPrevUnread :: Monad m => State -> m State
-moveCursorUpToPrevUnread =
-    moveCursorToUnread findPrev topOverrun moveTreeDown
-
-moveCursorDownToNextUnread :: Monad m => State -> m State
-moveCursorDownToNextUnread =
-    moveCursorToUnread findNext botOverrun moveTreeUp
-
-
-toggleFold :: State -> IO State
-toggleFold q@State{..} =
-    getNewSubForest >>= return . \case
-        Left err ->
-            q { flashMessage = SGR [31] $ Plain err }
-        Right sf ->
-            q { cursor = Z.modifyTree (setSubForest sf) cursor }
-  where
-    getNewSubForest =
-        if hasUnloadedSubForest (Z.tree cursor)
-            then loadSubForest (Z.label cursor)
-            else return $ Right $ unloadSubForest (Z.tree cursor)
-
-
-toggleTagAtCursor :: Tag -> State -> IO State
-toggleTagAtCursor tag q@State{..} = case Z.label cursor of
-
-    TVSearchResult sr -> do
-        let tagOp =
-                if tag `elem` Notmuch.searchTags sr
-                    then DelTag
-                    else AddTag
-            tagOps = [tagOp tag]
-        Notmuch.notmuchTag tagOps sr
-        let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor
-        return q { cursor = cursor' }
-
-    TVMessage m -> do
-        let tagOp =
-                if tag `elem` Notmuch.messageTags m
-                    then DelTag
-                    else AddTag
-            tagOps = [tagOp tag]
-        Notmuch.notmuchTag tagOps m
-        let cursor' =
-                -- TODO this needs a nice name
-                modifyFirstParentLabelWhere isTVSearchResult f $
-                Z.modifyLabel f cursor
-            f = patchTags tagOps
-        return q { cursor = cursor' }
-
-    _ -> return q { flashMessage = "nothing happened" }
-
-
 attachFilesToDraft :: State -> IO State
 attachFilesToDraft q0 =
     runExceptT (go q0) >>= return . \result ->
@@ -650,11 +485,6 @@ editTagsAtCursor q0 =
 -- utilities
 --
 
-
-setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a
-setSubForest sf t = t { Tree.subForest = sf }
-
-
 patchMessage
     :: [TagOp] -> Z.TreePos Z.Full TreeView -> Z.TreePos Z.Full TreeView
 patchMessage tagOps loc =