summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Action.hs184
-rw-r--r--test5.hs172
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 =