matsuri 0.0.1 → 0.0.2
raw patch · 9 files changed
+325/−264 lines, 9 files
Files
- Buffers.hs +13/−3
- Help.hs +5/−5
- Jabber.hs +23/−7
- Main.hs +19/−13
- UI.hs +33/−20
- Widgets/EditBox.hs +158/−35
- Widgets/ListBox.hs +71/−0
- Widgets/Tree.hs +0/−179
- matsuri.cabal +3/−2
Buffers.hs view
@@ -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
Help.hs view
@@ -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"
Jabber.hs view
@@ -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.
Main.hs view
@@ -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
UI.hs view
@@ -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`)
Widgets/EditBox.hs view
@@ -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) ' '++
+ Widgets/ListBox.hs view
@@ -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
− Widgets/Tree.hs
@@ -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
matsuri.cabal view
@@ -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 <newanon@yandex.ru>,@@ -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,