From 8e261623d63471f9b711bb02c6a8620aa9fc9561 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Tue, 22 Sep 2020 21:43:57 +0200 Subject: Action: init --- test5.hs | 172 +-------------------------------------------------------------- 1 file changed, 1 insertion(+), 171 deletions(-) (limited to 'test5.hs') 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 = -- cgit v1.2.3