diff --git a/Buffers.hs b/Buffers.hs --- a/Buffers.hs +++ b/Buffers.hs @@ -1,6 +1,6 @@ -- | Buffers.hs --- A module which contain buffer structures (structures which contain --- text and info about opened rooms and privates). +-- A module with defenition of buffer structures (structures which +-- contain text and info about opened rooms and privates). module Buffers where @@ -18,6 +18,7 @@ data Buffer = BufHelp [Content] | BufAccount Account | BufChat Chat + | BufGroup Group | BufGroupchat Groupchat -- Show instances @@ -27,8 +28,11 @@ case connection acc of OK _ _ -> c:" [o] "++accName acc NoConnection -> c:" [_] "++accName acc - Trying -> c:" [c] "++accName acc + Trying -> c:" [!] "++accName acc where c = if accCollapsed acc then '+' else '-' + show (BufGroup grp) = coll++grpName grp + where coll = if grpCollapsed grp then " +++ " + else " --- " show (BufChat chat) = " "++(show $ status chat)++ " "++(itemJid $ item chat) show (BufGroupchat _) = "" @@ -56,6 +60,12 @@ data Connection = OK TCPConnection ThreadId | NoConnection | Trying + +data Group = Group + { grpName :: String + , grpCollapsed :: Bool + , grpItems :: [String] + } data Chat = Chat { item :: RosterItem diff --git a/Help.hs b/Help.hs --- a/Help.hs +++ b/Help.hs @@ -13,8 +13,8 @@ \\n\ \Hotkeys:\n\ \\n\ -\C-n C-p -- moves in roster\n\ -\C-a C-f C-b C-e -- moves in edit box\n\ -\C-v -- show/hide roster\n\ -\RET -- collapse/expand group\n\ -\C-q -- exit" +\C-n C-p -- moves in roster\n\ +\C-a C-f C-b C-e M-f M-b -- moves in edit box\n\ +\C-v -- show/hide roster\n\ +\RET -- collapse/expand group\n\ +\C-q -- exit" diff --git a/Jabber.hs b/Jabber.hs --- a/Jabber.hs +++ b/Jabber.hs @@ -15,6 +15,7 @@ import Control.Concurrent import Control.Concurrent.MVar import Data.Maybe +import Data.List connect :: MVar MEvent -> Config -> Account -> IO Buffer @@ -32,9 +33,15 @@ if err == 0 then do tId <- liftIO $ myThreadId - insConn (OK c tId) + put $ insConn (OK c tId) - mapM_ (liftIO . putMVar mev . insBuf c) =<< getRoster + items <- getRoster + mapM_ (put . insChat c) items + -- create groups; if roster item doesn't have any + -- groups then it's element of "other" group + mapM_ (put . insGroup items) (groups items) + put $ insOtherGroup items + sendPresence -- set handlers handleVersion (getCF "client" config) @@ -43,18 +50,27 @@ addHandler isChat (chatCB mev k) True addHandler isPresence (presenceCB mev k) True --- - else insConn NoConnection + else put $ insConn NoConnection return $ doBuf Trying _ -> return (BufAccount acc) where - insConn = liftIO . putMVar mev . InsBuffer (accName acc) . doBuf + put = liftIO . putMVar mev + k = accName acc + insConn = InsBuffer k . doBuf doBuf conn = BufAccount acc{connection=conn} - k = accName acc - insBuf c item = InsBuffer (chatName' item) (item2buf c item) - item2buf c item = BufChat (Chat item offline (chatName' item) c []) + insChat c item = InsBuffer (chatName' item) (item2chat c item) + item2chat c item = BufChat (Chat item offline (chatName' item) c []) offline = Status StatusOffline [] chatName' item = k++"|"++itemJid item + + insGroup items name = insGroup' (name `elem`) items name + insOtherGroup items = insGroup' null items "other" + groups = nub . concat . map itemGroups + insGroup' p items name = InsBuffer (k++"|"++name) (grp p name items) + grp p name = BufGroup . Group name False . grpItems' p name + grpItems' p name + = map chatName' . filter (p . itemGroups) -- | Close account connection. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -15,7 +15,7 @@ import qualified Data.Map as M import Graphics.Vty import Graphics.Vty.Widgets.All -import qualified Widgets.Tree as T +import qualified Widgets.ListBox as L import qualified Widgets.EditBox as E @@ -27,7 +27,9 @@ mev <- newEmptyMVar -- main loop forkIO $ loopGetEvent mev vty - rerender mev vty (defaultUI buffers) config buffers + DisplayRegion w h <- display_bounds $ terminal vty + let ui = resizeUI (fromIntegral w) (fromIntegral h) $ defaultUI buffers + rerender mev vty ui config buffers -- disconnect all accounts mapM_ disconnect $ [acc | BufAccount acc <- (M.elems buffers)] -- shutdown && exiting @@ -59,13 +61,16 @@ --- VtyEvent event' -> case event' of -- tree - EvKey (KASCII 'p') [MCtrl] -> rerender' $ st { roster = T.moveUp roster } - EvKey (KASCII 'n') [MCtrl] -> rerender' $ st { roster = T.moveDn roster } + EvKey (KASCII 'p') [MCtrl] -> rerender' $ st { roster = L.moveUp roster } + EvKey (KASCII 'n') [MCtrl] -> rerender' $ st { roster = L.moveDn roster } EvKey KEnter [] | E.contents edit == "" -> - case getAccount cur buffers of - Just acc -> + case getBuf cur buffers of + BufAccount acc -> let buf = BufAccount acc{accCollapsed = not $ accCollapsed acc} in insElem' cur buf + BufGroup grp -> + let buf = BufGroup grp{grpCollapsed = not $ grpCollapsed grp} + in insElem' cur buf _ -> skip -- show/hide @@ -81,6 +86,8 @@ EvKey (KASCII 'a') [MCtrl] -> rerender' $ st { edit = E.moveToHome edit } EvKey (KASCII 'f') [MCtrl] -> rerender' $ st { edit = E.moveRight edit } EvKey (KASCII 'b') [MCtrl] -> rerender' $ st { edit = E.moveLeft edit } + EvKey (KASCII 'f') [MMeta] -> rerender' $ st { edit = E.moveWordRight edit } + EvKey (KASCII 'b') [MMeta] -> rerender' $ st { edit = E.moveWordLeft edit } EvKey (KASCII 'e') [MCtrl] -> rerender' $ st { edit = E.moveToEnd edit } EvKey KBS [] -> rerender' $ st { edit = E.backSpace edit } EvKey KDel [] -> rerender' $ st { edit = E.delete edit } @@ -89,20 +96,20 @@ "/q" -> return () ('/':cmd) -> do buffers' <- parseCmd cmd - let st' = st { edit = E.empty - , roster = mkTree roster buffers' + let st' = st { edit = E.empty edit + , roster = mkListBox roster buffers' } rerender mev vty st' config buffers' msg -> case getBuf cur buffers of BufChat chat -> do buffer <- sendChatMessage chat (E.contents edit) let buffers' = insElem cur buffer buffers - st' = st { edit = E.empty } + st' = st { edit = E.empty edit } rerender mev vty st' config buffers' _ -> skip -- other - EvResize w h -> rerender' st + EvResize w h -> rerender' $ resizeUI w h st EvKey (KASCII 'q') [MCtrl] -> return () _ -> skip where @@ -112,7 +119,7 @@ -- and re-create roster tree insElem' k buffer = let buffers' = insElem k buffer buffers - st' = st { roster = mkTree roster buffers' } + st' = st { roster = mkListBox roster buffers' } in rerender mev vty st' config buffers' -- connect parseCmd "c" = case getAccount cur buffers of @@ -128,13 +135,12 @@ buffers'' = killBuffers (accName acc++"|") buffers' return buffers'' _ -> ins2help (InfoMsg "can't disconnect: not an account") - where cur = T.cur roster -- help parseCmd "help" = ins2help (InfoMsg help_all) parseCmd unknown_cmd = ins2help (InfoMsg $ "unknown `"++unknown_cmd++ "' command, try `/help'") --- - cur = T.cur roster + cur = L.cur roster ins2help cnt = return $ case getBuf "help" buffers of BufHelp cnts -> insElem "help" (BufHelp $ cnt:cnts) buffers _ -> buffers diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -5,27 +5,28 @@ module UI ( UIState(..), mkUI, - mkTree, - defaultUI + mkListBox, + defaultUI, + resizeUI ) where import Buffers import Config -import qualified Widgets.Tree as T +import qualified Widgets.ListBox as L import qualified Widgets.EditBox as E import Widgets.PrettyBorders import Widgets.TextBox import Graphics.Vty import Graphics.Vty.Widgets.All -import Data.Tree import qualified Data.Map as M +import Data.Maybe import Data.List data UIState = UIState - { roster :: T.Tree + { roster :: L.ListBox , textBox :: TextBox , edit :: E.EditBox } @@ -39,7 +40,7 @@ <--> text (back blue) "info" <--> edit where - tb = case getBuf (T.cur roster) buffers of + tb = case getBuf (L.cur roster) buffers of BufHelp cnts -> mkTextBox cnts config BufChat chat -> mkTextBox (chatContents chat) config _ -> mkTextBox [] config @@ -55,32 +56,44 @@ cnt2line (InfoMsg msg) = (fore cyan, msg) -mkTree :: T.Tree -> Buffers -> T.Tree -mkTree roster buffers = - roster { T.nodes = ns } +mkListBox :: L.ListBox -> Buffers -> L.ListBox +mkListBox roster buffers = + roster { L.items = items } where - -- all nodes - ns = (Node (T.NodeData False ("[help]", "help")) []):(map mkAcc accs) + -- all items + items = ("[help]", "help"):(concat $ map mkAcc accs) -- accounts accs = [ buf | buf@(BufAccount _) <- M.elems buffers ] --- mkAcc buf@(BufAccount acc) - = Node (T.NodeData (accCollapsed acc) (show buf, accName acc)) - $ map (mkChat (accCollapsed acc)) (chats acc) - mkChat coll buf@(BufChat chat) - = Node (T.NodeData coll (show buf, chatName chat)) [] - -- get all chats account - chats acc - = M.elems $ M.filterWithKey (filt (accName acc++"|")) buffers + = (show buf, accName acc): + (if accCollapsed acc + then [] + else concat $ map (mkGroup (accName acc)) (groups acc)) + mkGroup k buf@(BufGroup grp) + = (show buf, k++"|"++grpName grp): + (if grpCollapsed grp + then [] + else map mkChat $ grpBufs $ grpItems grp) + mkChat buf@(BufChat chat) + = (show buf, chatName chat) + -- get acc groups + groups acc = [ buf | buf@(BufGroup _) <- els ] + where els = M.elems + $ M.filterWithKey (filt (accName acc++"|")) buffers filt prefix k _ = prefix `isPrefixOf` k + -- get group chats + grpBufs = catMaybes . map (flip M.lookup buffers) defaultUI :: Buffers -> UIState defaultUI buffers - = UIState { roster = mkTree (T.defaultTree []) buffers + = UIState { roster = mkListBox L.empty buffers , textBox = TextBox [] - , edit = E.empty + , edit = E.defaultEditBox } + +resizeUI w _ ui@(UIState{..}) = ui {edit = E.resize w edit} --- fore = (def_attr `with_fore_color`) diff --git a/Widgets/EditBox.hs b/Widgets/EditBox.hs --- a/Widgets/EditBox.hs +++ b/Widgets/EditBox.hs @@ -1,74 +1,197 @@ + {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} --- | EditBox.hs --- Multiline edit box widget. -module Widgets.EditBox where +-- | One-line edit box widget. +module Widgets.EditBox + ( EditBox + , editBox + , defaultEditBox + , fixedWidthEditBox + , fixedWidthDefaultEditBox + , empty + , contents + , current + + , defaultKeyHandler + , insert + , moveLeft + , moveRight + , moveWordLeft + , moveWordRight + , moveToHome + , moveToEnd + , backSpace + , delete + , resize + ) + where + + +import Data.Char + import Graphics.Vty import Graphics.Vty.Widgets.Base import Graphics.Vty.Widgets.WrappedText --- | TODO: multiline -data EditBox = EditBox { front, back :: String } +-- | Edit box can have fixed width or it expands to fill all available space. +-- | TODO: если размеры будут задаваться внешними по отношению к vty-ui методами, то разделение на fixed/free не нужно +data Size = Free {getSize :: Int} | Fixed {getSize :: Int} +data EditBox + = EditBox + { primAttr :: Attr + , currentAttrFn :: Attr -> Attr + , width :: Size + , windowStart :: Int + , front :: String -- ^ text before cursor (in reversed order) + , back :: String -- ^ current char and text after it + } + ---------------------------------------------------------------------- --- | Create empty edit box. -empty :: EditBox -empty = EditBox "" "" +-- | Creates empty edit box that fills all available width. +editBox attr fn = EditBox attr fn (Free 0) 0 "" "" +defaultEditBox = editBox def_attr (`with_style` reverse_video) --- | Get contents. -contents :: EditBox -> String +-- | Creates empty edit box with fixed width. +fixedWidthEditBox attr fn w = EditBox attr fn (Fixed w) 0 "" "" +fixedWidthDefaultEditBox = fixedWidthEditBox def_attr (`with_style` reverse_video) + + +-- | Empties edit box. +empty t = t {windowStart = 0, front = "", back = ""} + +-- | Returns text contained in edit box. contents (EditBox{..}) = reverse front ++ back --- | Insert new symbol. -insert :: Char -> EditBox -> EditBox -insert c box = box {front = c : front box} +-- | Returns current character. +current (EditBox{back}) + = if null back then Nothing else Just $ head back -resize w h = id +-- | Returns current size of edit box. +size = getSize . width +-- | Handles key events from vty +defaultKeyHandler box ev + = ($box) $ case ev of + EvKey (KASCII c) [] -> Just . insert c + EvKey KLeft [] -> Just . moveLeft + EvKey KRight [] -> Just . moveRight + EvKey KLeft [MCtrl] -> Just . moveWordLeft + EvKey KRight [MCtrl] -> Just . moveWordRight + EvKey KHome [] -> Just . moveToHome + EvKey KEnd [] -> Just . moveToEnd + EvKey KBS [] -> Just . backSpace + EvKey KDel [] -> Just . delete + _ -> const Nothing + ---------------------------------------------------------------------- -- editing commands -- TODO: more text editing commands (delete-world, delete-line and so on). +-- FIXME: tab breaks input -moveLeft box@(EditBox{front = c:front', back}) = box {front = front', back = c:back} +-- | Inserts one symbol before cursor. +insert c box = scrollWindow $ box {front = c':front box} + where -- FIXME: что делать с tab'ом в insert? | а ничего с ним не + -- надо, по табу ники перебирать же. + c' = if elem c "\r\n\t" then ' ' else c -- filter 'bad' symbols + +-- | Moves cursor one position left. Scrolls text if necessary. +moveLeft box@(EditBox{front = c:front',back}) + = scrollWindow $ box {front = front', back = c:back} moveLeft box = box -moveRight box@(EditBox{front, back = c:back'}) = box {front = c:front, back = back'} +-- | Moves cursor one position right. Scrolls text if necessary. +moveRight box@(EditBox{front, back = c:back'}) + = scrollWindow $ box {front = c:front, back = back'} moveRight box = box -moveToHome box = box {front = "", back = contents box} -moveToEnd box = box {front = reverse $ contents box, back = ""} -backSpace box@(EditBox{front = c:front'}) = box {front = front'} +-- | Skip all spaces then skip word. +skipWord move + = head + . dropWhile (inBounds .&&. (inWord.current)) + . dropWhile (inBounds .&&. (not.inWord.current)) + . iterate move + . move + where + inWord Nothing = False + inWord (Just c) = isAlphaNum c + inBounds = (not.null.front) .&&. (not.null.back) + +(.&&.) f g x = f x && g x + +-- | Moves cursor one word left. Scrolls if necessary. +moveWordLeft = skipWord moveLeft + +-- | Moves cursor one word right. Scrolls if nesessary. +moveWordRight = skipWord moveRight + +-- | Moves cursor to the very beginning of the text. +moveToHome box = scrollWindow $ box {front = "", back = contents box} + +-- | Moves cursor to the end of the text. +moveToEnd box = scrollWindow $ box {front = reverse $ contents box, back = ""} + +-- | Removes symbol before cursor. +backSpace box@(EditBox{front = c:front'}) = scrollWindow $ box {front = front'} backSpace box = box -delete box@(EditBox{back = c:back'}) = box {back = back'} +-- | Removes current symbol. +delete box@(EditBox{back = c:back'}) = scrollWindow $ box {back = back'} delete box = box +-- | Updates internal variable that represents edit box width. +-- Used only as a response to EvResize. +-- If you wish to resize fixed size edit box, you need to creatie a new one. +resize w box@(EditBox{width}) + = case width of + Free _ -> scrollWindow $ box {width = Free w} + _ -> box + +-- | Scrolls text if cursor is not visible. +scrollWindow box@(EditBox{front, width, windowStart = ws}) + | fLen - ws > w-1 = box {windowStart = fLen - w+1} + | fLen < ws = box {windowStart = fLen} + | otherwise = box + where + fLen = length front + w = getSize width + + ---------------------------------------------------------------------- -- render instance Widget EditBox where - growHorizontal _ = True + -- growHorizontal :: w -> Bool + growHorizontal (EditBox{width = Free _}) = True + growHorizontal _ = False + + -- growVertical :: w -> Bool growVertical _ = False - primaryAttribute _ = def_attr - withAttribute w _ = w - -- TODO: convert empty lines to hFill's - render rgn box@(EditBox{front, back}) - = render rgn $ case back of - c : back' -> text def_attr (reverse front) - <++> cursor c - <++> text def_attr back' - <++> hFill def_attr ' ' 1 - [] -> text def_attr (reverse front) - <++> cursor ' ' - <++> hFill def_attr ' ' 1 + -- primaryAttribute :: w -> Attr + primaryAttribute = primAttr + + -- withAttribute :: w -> Attr -> w + withAttribute w a = w {primAttr = a} + + -- render :: DisplayRegion -> w -> Image + render rgn box@(EditBox{..}) + = render rgn + $ text primAttr front' + <++> text (currentAttrFn primAttr) [c] + <++> text primAttr (back' ++ fill) where - cursorAttr = def_attr `with_style` reverse_video - cursor c = text cursorAttr [c] + front' = drop windowStart $ reverse front + (c:back') + | null back = ' ':[] + | otherwise = take (getSize width - length front') back + fill = replicate (getSize width - length front' - length back' - 1) ' ' + + diff --git a/Widgets/ListBox.hs b/Widgets/ListBox.hs new file mode 100644 --- /dev/null +++ b/Widgets/ListBox.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | ListBox.hs +-- ListBox widget. +module Widgets.ListBox where + +import Graphics.Vty +import Graphics.Vty.Widgets.Base + + +data ListBox + = ListBox + { selectedAttr :: Attr + , defaultAttr :: Attr + , selectedIndex :: Int + , listWidth :: Int + , items :: [(String, Value)] + } +type Value = String + +empty + = ListBox + { selectedAttr = def_attr `with_back_color` cyan + `with_fore_color` blue + , defaultAttr = def_attr + , selectedIndex = 0 + , listWidth = 30 + , items = [] + } + + +---------------------------------------------------------------------- +-- moves +-- TODO: first, end, pageup, pagedn + +moveUp l@(ListBox {selectedIndex = sIx}) + | sIx == 0 = l + | otherwise = l { selectedIndex = sIx-1 } + +moveDn l@(ListBox {selectedIndex = sIx}) + | sIx == listSize - 1 = l + | otherwise = l { selectedIndex = sIx+1 } + where + listSize = length $ items l + + +---------------------------------------------------------------------- +-- rendering + +instance Widget ListBox where + growHorizontal _ = False + growVertical _ = True + primaryAttribute _ = def_attr + withAttribute w _ = w + + render rgn l@(ListBox {..}) + = vert_cat + $ map (renderLine defaultAttr) a + ++ [renderLine selectedAttr n] + ++ map (renderLine defaultAttr) b + where + width = listWidth + height = fromIntegral $ region_height rgn + (a, n:b) = splitAt selectedIndex items + renderLine attr = string attr . take' width ' ' . fst + +--- +cur l = snd $ (items l)!!(selectedIndex l) +take' n add lst = if length lst < n + then lst ++ replicate (n - length lst) add + else take n lst diff --git a/Widgets/Tree.hs b/Widgets/Tree.hs deleted file mode 100644 --- a/Widgets/Tree.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Tree.hs --- Tree widget. -module Widgets.Tree ( - Tree(..), - NodeData(..), - defaultTree, - moveUp, - moveDn, - cur -) where - -import Prelude hiding (sequence, mapM) -import Control.Monad.State.Lazy hiding (sequence, mapM) -import Data.Traversable (sequence, mapM) -import Data.Tree hiding (Tree) -import Data.Maybe -import Graphics.Vty -import Graphics.Vty.Widgets.Base - - --- | Дерево хранится в виде Forest (NodeData a). --- Поскольку используется готовое дерево, приходится вручную везде --- проверять инвариант "если дочерних узлов нет, то узел считается --- развёрнутым". -data Tree - = Tree - { selectedAttr :: Attr - , nodeAttr :: Attr - , selectedIndex :: Int - , windowStart :: Int - , treeWidth :: Maybe Int - , treeHeight :: Maybe Int - , nodes :: Forest NodeData - } - -data NodeData = NodeData {collapsed :: Bool, value :: (String, Value)} -type Value = String - -defaultTree tree - = Tree - { selectedAttr = def_attr `with_back_color` cyan `with_fore_color` blue - , nodeAttr = def_attr - , selectedIndex = 0 - , windowStart = 0 - , treeWidth = Just 30 - , treeHeight = Nothing - , nodes = tree - } - - ----------------------------------------------------------------------- --- moves --- TODO: first, end, pageup, pagedn - -moveUp t@(Tree {windowStart = ws, selectedIndex = sIx}) - | sIx == ws && ws == 0 = t - | sIx == ws = t { windowStart = ws-1, selectedIndex = sIx-1 } - | otherwise = t { selectedIndex = sIx-1 } - -moveDn t@(Tree {selectedIndex = sIx}) - | sIx == treeSize - 1 = t - | otherwise = t { selectedIndex = sIx+1 } - where - treeSize = length $ concatMap (flatten . filterVisible) $ nodes t - - ----------------------------------------------------------------------- --- collapse/expand - --- | If tree expanded then collapse it, else expand. -collapseOrExpand t - = if collapsed $ current t then expand t - else collapse t - --- | Collapse or expand only current node. -collapse t@(Tree {..}) = t {nodes = setCollapsed True selectedIndex nodes} -expand t@(Tree {..}) = t {nodes = setCollapsed False selectedIndex nodes} - --- FIXME: работает совсем неправильно --- | Collapse current node or if already collapsed then collapse --- parent. -collapse' t@(Tree {..}) = t - { selectedIndex = parentIx - , nodes = setCollapsed True parentIx nodes - } - where - -- ищем узел, который нужно свернуть. Это может быть: - -- - выбранный узел, если у него есть вложенные узлы и он сам - -- развёрнут - -- - иначе, сворачиваем родителя выбранного узла - parentIx = fst $ foldl getParent1 (0, 0) nodes - - -- для самого верхнего уровня логика немного отличается: - -- если узел свёрнут или он лист, то ничего не происходит (потому - -- как родительского узла нет) - getParent1 (p,ix) n = if ix <= selectedIndex then getParent' (ix,ix) n else (p,ix) - -- у вложенных узлов всегда есть родитель которого можно свернуть - getParent2 (p,ix) n = if ix <= selectedIndex then getParent' (p,ix) n else (p,ix) - - getParent' (p,ix) (Node n ns) - -- если выбран лист дерева или свёрнутый узел, нужно сворачивать - -- ветку на которой он висит - -- если выбран развёрнутый узел дерева, значит его самого и - -- сворачиваем - | ix == selectedIndex = if null ns || collapsed n then (p,ix+1) else (ix,ix+1) - -- до выбранного узла ещё не добрались, встретили развёрнутый, - -- запоминаем его как родительский и заходим внутрь - | (not.collapsed) n && (not.null) ns = foldl getParent2 (ix,ix+1) ns - -- встретили лист или свёрнутый узел, проходим мимо - | otherwise = (p,ix+1) - -setCollapsed value nodeIx nodes = evalState (mapM setCollapsed' nodes) 0 - where - setCollapsed' (Node n ns) = do - ix <- get - put $ ix + 1 - if ix == nodeIx - -- проверяем null ns, чтобы не было крестиков около листьев - then return $ Node (n {collapsed = value && (not.null) ns}) ns - else if collapsed n || ix > nodeIx - then return $ Node n ns - else Node n `fmap` mapM setCollapsed' ns - -{- TODO: сделать monad transformer -appendIndex nodes = evalState (mapM (mapNode index) nodes) 0 - where - index = getIndex >>= \ix -> put (Index $ ix+1) >> return ix - noIndex = return $ Index (-1) - - mapNode indexProvider (Node n ns) = do - ix <- indexProvider - ns' <- mapM (mapNode $ if collapsed n then noIndex else index) ns - return $ Node (ix,n) ns' --} - - ----------------------------------------------------------------------- --- rendering - -instance Widget Tree where - growHorizontal t = isNothing (treeWidth t) - growVertical t = isNothing (treeHeight t) - primaryAttribute _ = def_attr - withAttribute w _ = w - - render rgn t@(Tree {..}) - = vert_cat - $ map (renderNode width nodeAttr) a - ++ [renderNode width selectedAttr n] - ++ map (renderNode width nodeAttr) b - where - width = maybe (fromIntegral $ region_width rgn) id treeWidth - height = maybe (fromIntegral $ region_height rgn) id treeHeight - Tree {windowStart = start} = resize width height t - (a, n:b) = splitAt (selectedIndex - start) $ window start height t - -renderNode width attr (depth, n) = string attr $ take' width ' ' $ fst $ value n - -resize _ h t@(Tree {windowStart = ws, selectedIndex = sIx}) - -- current node is out of view => scroll up until it is visible - | sIx > ws + h - 1 = t { windowStart = sIx - h + 1 } - -- we have free space after last node => scroll down to fill it - | wl < h = t { windowStart = max 0 $ ws - (h - wl) } - | otherwise = t - where - wl = length $ window ws h t - - ---- -cur = snd . value . current -current t = (concatMap flatten $ map filterVisible $ nodes t) !! selectedIndex t -window start sz = take sz . drop start . concatMap (flatten . appendDepths 0 . filterVisible) . nodes -appendDepths d (Node n ns) = Node (d,n) $ map (appendDepths (d+1)) ns -filterVisible (Node n ns) = Node n $ if collapsed n then [] else map filterVisible ns -take' n add lst = if length lst < n - then lst ++ replicate (n - length lst) add - else take n lst diff --git a/matsuri.cabal b/matsuri.cabal --- a/matsuri.cabal +++ b/matsuri.cabal @@ -1,6 +1,7 @@ Name: matsuri -Version: 0.0.1 +Version: 0.0.2 Category: Network +Synopsis: ncurses XMPP client License: GPL License-File: LICENSE Author: Kagami , @@ -20,7 +21,7 @@ Other-Modules: Buffers, Config, Help, Jabber, UI, Utils, Widgets.EditBox, Widgets.PrettyBorders, - Widgets.TextBox, Widgets.Tree + Widgets.TextBox, Widgets.ListBox Build-Depends: base >= 4 && < 5, vty >= 4, vty-ui >= 0.2, containers, mtl, network, split, directory,