diff options
| -rw-r--r-- | Action.hs | 184 | ||||
| -rw-r--r-- | test5.hs | 172 |
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 } + @@ -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 = |