diff --git a/Manatee/Core/Page.hs b/Manatee/Core/Page.hs --- a/Manatee/Core/Page.hs +++ b/Manatee/Core/Page.hs @@ -29,10 +29,10 @@ pageNew pId pType plug pvw = return $ Page pId pType plug pvw --- | Page scrolled window. -pageScrolledWindow :: Page -> ScrolledWindow -pageScrolledWindow page = - pageApplyViewWrap page pageViewScrolledWindow +-- | Page box. +pageBox :: Page -> VBox +pageBox page = + pageApplyViewWrap page pageViewBox -- | Applying function with page buffer. pageApplyViewWrap :: Page -> (forall a . PageView a => a -> b) -> b diff --git a/Manatee/Core/PageFrame.hs b/Manatee/Core/PageFrame.hs new file mode 100644 --- /dev/null +++ b/Manatee/Core/PageFrame.hs @@ -0,0 +1,88 @@ +-- Author: Andy Stewart +-- Maintainer: Andy Stewart +-- +-- Copyright (C) 2010 Andy Stewart, all rights reserved. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +module Manatee.Core.PageFrame where + +import Graphics.UI.Gtk hiding (Statusbar, statusbarNew) +import Manatee.Toolkit.General.String +import Manatee.Toolkit.Gtk.Gtk +import Manatee.Toolkit.Gtk.ScrolledWindow +import Manatee.Toolkit.Widget.Outputbar +import Manatee.Toolkit.Widget.Statusbar + +data PageFrame = + PageFrame {pageFrameBox :: VBox -- box for contain `PageView' + ,pageFrameFrame :: Frame -- frame + ,pageFrameScrolledWindow :: ScrolledWindow -- scrolled window + ,pageFrameOutputbar :: Outputbar -- outputbar for display message + ,pageFrameStatusbar :: Statusbar -- statusbar + } + +-- | Create 'PageFrame'. +pageFrameNew :: IO PageFrame +pageFrameNew = do + -- Create box. + box <- vBoxNew False 0 + + -- Body frame. + frame <- frameNewWithShadowType Nothing + boxPackStart box frame PackGrow 0 + + -- Scrolled Window. + scrolledWindow <- scrolledWindowNew_ + frame `containerAdd` scrolledWindow + + -- Outputbar. + outputbar <- outputbarNew + + -- Statusbar. + statusbar <- statusbarNew box + + return $ PageFrame box frame scrolledWindow outputbar statusbar + +-- | Page frame new with mode name. +pageFrameNewWithModeName :: String -> IO PageFrame +pageFrameNewWithModeName name = do + frame <- pageFrameNew + pageFrameUpdateStatusbar frame "PageMode" ("Mode (" ++ name ++ ")") + return frame + +-- | Add child. +pageFrameAddChild :: WidgetClass widget => PageFrame -> widget -> IO () +pageFrameAddChild pageFrame widget = + pageFrameScrolledWindow pageFrame `containerAdd` widget + +-- | Show outputbar. +pageFrameShowOutputbar :: PageFrame -> String -> Maybe Int -> IO () +pageFrameShowOutputbar pageFrame output limit = do + let str = case limit of + Just l -> stripFormat output l + Nothing -> output + outputbarShow (pageFrameBox pageFrame) + (pageFrameOutputbar pageFrame) + str + +-- | Update statusbar. +pageFrameUpdateStatusbar :: PageFrame -> String -> String -> IO () +pageFrameUpdateStatusbar pageFrame = + statusbarInfoItemUpdate (pageFrameStatusbar pageFrame) + +-- | Update statusbar. +pageFrameUpdateProgress :: PageFrame -> Double -> IO () +pageFrameUpdateProgress pageFrame = + statusbarProgressUpdate (pageFrameStatusbar pageFrame) diff --git a/Manatee/Core/PageView.hs b/Manatee/Core/PageView.hs --- a/Manatee/Core/PageView.hs +++ b/Manatee/Core/PageView.hs @@ -31,7 +31,6 @@ import Manatee.Core.Types import Manatee.Toolkit.General.Basic import Manatee.Toolkit.General.Maybe -import Manatee.Toolkit.General.String import Graphics.UI.Gtk.General.General import qualified Data.Map as M @@ -78,34 +77,6 @@ pageViewGetPlugId :: forall a . PageView a => a -> IO PagePlugId pageViewGetPlugId = readTVarIO . pageViewPlugId --- | Update output. -pageViewUpdateOutputStatus :: forall a . PageView a => a -> String -> Maybe Int -> IO () -pageViewUpdateOutputStatus view output limit = do - plugId <- pageViewGetPlugId view - let str = case limit of - Just l -> stripFormat output l - Nothing -> output - mkDaemonSignal (pageViewClient view) - LocalOutputbarUpdate - (LocalOutputbarUpdateArgs plugId str) - --- | Update progress. -pageViewUpdateProgressStatus :: forall a . PageView a => a -> Double -> IO () -pageViewUpdateProgressStatus view progress = do - plugId <- pageViewGetPlugId view - mkDaemonSignal (pageViewClient view) - LocalProgressUpdate - (LocalProgressUpdateArgs plugId progress) - - --- | Update status. -pageViewUpdateInfoStatus :: forall a . PageView a => a -> String -> String -> IO () -pageViewUpdateInfoStatus view item status = do - plugId <- pageViewGetPlugId view - mkDaemonSignal (pageViewClient view) - LocalStatusbarUpdate - (LocalStatusbarUpdateArgs plugId item status) - -- | Get dbus client. pageViewClient :: forall a . PageView a => a -> Client pageViewClient view = @@ -116,19 +87,19 @@ pageViewCutAction :: forall a . PageView a => a -> IO () pageViewCutAction view = unlessM (pageViewCut view) $ - pageViewUpdateOutputStatus view "Haven't implement pageViewCut" Nothing + putStrLn "pageViewCutAction : Haven't implement pageViewCut." -- | Copy action. pageViewCopyAction :: forall a . PageView a => a -> IO () pageViewCopyAction view = unlessM (pageViewCopy view) $ - pageViewUpdateOutputStatus view "Haven't implement pageViewCopy" Nothing + putStrLn "pageViewCopyAction : Haven't implement pageViewCopy." -- | Paste action. pageViewPasteAction :: forall a . PageView a => a -> IO () pageViewPasteAction view = unlessM (pageViewPaste view) $ - pageViewUpdateOutputStatus view "Haven't implement pageViewPaste" Nothing + putStrLn "pageViewPasteAction : Haven't implement pageViewPaste." -- | Call local interactive. localInteractive :: forall a . PageView a => a -> String -> ([String] -> IO ()) -> IO () diff --git a/Manatee/Core/Render.hs b/Manatee/Core/Render.hs --- a/Manatee/Core/Render.hs +++ b/Manatee/Core/Render.hs @@ -78,17 +78,28 @@ bufferWrap <- bufferNewFun pagePath options client pageId customizeWrap -- Build render client for listen dbus signal. - mkRenderClient client bufferWrap customizeWrap processId pageList pType + pongStatusTVar <- newTVarIO GotPongMessage + mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar -- Create first page. renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True + -- Send ping signal. + renderSendPing client pongStatusTVar + -- Loop. mainGUI -- | Build render client for listen dbus signal. -mkRenderClient :: Client -> PageBufferWrap -> CustomizeWrap -> ProcessID -> TVar PageList -> PageType -> IO () -mkRenderClient client bufferWrap customizeWrap processId pageList pType = +mkRenderClient :: Client + -> PageBufferWrap + -> CustomizeWrap + -> ProcessID + -> TVar PageList + -> PageType + -> TVar PongStatus + -> IO () +mkRenderClient client bufferWrap customizeWrap processId pageList pType pongStatusTVar = -- Build match rule. mkRenderMatchRules client [(CloneRenderPage, renderHandleClonePage client bufferWrap pageList processId pType) @@ -99,6 +110,7 @@ ,(ExitRenderProcess, renderHandleExitProcess client processId) ,(UpdateConfig, renderHandleUpdateConfig customizeWrap) ,(InstallConfig, renderHandleInstallConfig bufferWrap) + ,(Pong, renderHandlePong pongStatusTVar) ] -- | Handle clone render page signal. @@ -129,7 +141,7 @@ -- Reparent. writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId -- update new page plug id - widgetReparent (pageScrolledWindow op) (plugBody newPlug) + widgetReparent (pageBox op) (plugBody newPlug) widgetShowAll $ plugBody newPlug -- New page. @@ -139,7 +151,7 @@ runTVarStateT pageList $ put . Set.insert page -- Destroy old plug. - renderHandleDestroyPage pageList (DestroyRenderPageArgs pageId oldPlugId) + renderHandleDestroyPage pageList (DestroyRenderPageArgs oldPlugId) -- Send `NewRenderPageConfirm` signal. let modeName = pageModeName $ pageBufferMode buffer @@ -163,7 +175,7 @@ page <- pageNew pageId pType plug viewWrap -- Create page and pageView. - plugBody plug `containerAdd` pageScrolledWindow page + plugBody plug `containerAdd` pageBox page widgetShowAll $ plugBody plug -- Add page to page list. @@ -197,20 +209,20 @@ -- | Handle destroy render page signal. renderHandleDestroyPage :: TVar PageList -> RenderSignalArgs -> IO () -renderHandleDestroyPage pageList (DestroyRenderPageArgs _ plugId) = +renderHandleDestroyPage pageList (DestroyRenderPageArgs plugId) = runTVarStateT pageList $ \pl -> - maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \mp -> do + maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \page -> do lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId -- Delete page from page list. - put (Set.delete mp pl) + put (Set.delete page pl) -- Destroy page. - lift $ plugDestroy $ pagePlug mp + lift $ plugDestroy $ pagePlug page -- | Handle exit process signal. renderHandleExitProcess :: Client -> ProcessID -> RenderSignalArgs -> IO () renderHandleExitProcess client processId (ExitRenderProcessArgs pageId) = do - -- Send RenderProcessExit signal to daemon process. - mkDaemonSignal client RenderProcessExit (RenderProcessExitArgs pageId processId) + -- Send RenderProcessExitConfirm signal to daemon process. + mkDaemonSignal client RenderProcessExitConfirm (RenderProcessExitConfirmArgs pageId processId) -- Quit process. mainQuit @@ -226,3 +238,35 @@ packageName <- pageBufferPackageName buffer runCommand_ ("cabal install " ++ packageName ++ " --reinstall") +-- | Handle pong signal. +renderHandlePong :: TVar PongStatus -> RenderSignalArgs -> IO () +renderHandlePong pongStatusTVar _ = + writeTVarIO pongStatusTVar GotPongMessage + +-- | Send ping signal. +-- Render process will send PING message in delay time. +-- Quit current process if not receive PONG message in next delay time. +-- Use for test daemon process whether live to avoid immortal process. +renderSendPing :: Client -> TVar PongStatus -> IO () +renderSendPing client pongStatusTVar = do + -- Get current process id. + processId <- getProcessID + let sendDelay = 5000 -- delay time to send ping message + + -- Send ping message in delay time. + timeoutAdd (do + pongStatus <- readTVarIO pongStatusTVar + case pongStatus of + GotPongMessage -> do + -- Send ping signal to test whether daemon process still live. + mkDaemonSignal client Ping (PingArgs processId) + -- Change pong status to WaitPongMessage. + writeTVarIO pongStatusTVar WaitPongMessage + WaitPongMessage -> do + -- Quit process if lost ping message. + putStrLn $ "Lost pong message from daemon process, quit process (" ++ show processId ++ ")" + mainQuit + return True) + sendDelay + + return () diff --git a/Manatee/Core/Types.hs b/Manatee/Core/Types.hs --- a/Manatee/Core/Types.hs +++ b/Manatee/Core/Types.hs @@ -158,6 +158,8 @@ class Typeable a => PageView a where pageViewBuffer :: a -> PageBufferWrap pageViewPlugId :: a -> TVar PagePlugId + pageViewBox :: a -> VBox + pageViewScrolledWindow :: a -> ScrolledWindow pageViewHandleKeyAction :: a -> Text -> SerializedEvent -> IO () pageViewFocus :: a -> IO () pageViewCopy :: a -> IO Bool @@ -166,7 +168,6 @@ pageViewCut _ = return False pageViewPaste :: a -> IO Bool pageViewPaste _ = return False - pageViewScrolledWindow :: a -> ScrolledWindow pageViewScrollToTop :: a -> IO () pageViewScrollToTop = scrolledWindowScrollToTop . pageViewScrolledWindow @@ -240,38 +241,36 @@ data DaemonMember = NewRenderPageConfirm | NewAnythingProcessConfirm - | RenderProcessExit + | RenderProcessExit + | RenderProcessExitConfirm | RenderProcessException | NewTab | AnythingViewOutput | LocalInteractivebarExit - | LocalOutputbarUpdate - | LocalStatusbarUpdate - | LocalProgressUpdate | SynchronizationPathName | ChangeTabName | SwitchBuffer | ShowTooltip | LocalInteractiveReturn | GlobalInteractiveReturn + | Ping deriving (Show, Eq, Ord) data DaemonSignalArgs = NewRenderPageConfirmArgs PageId PageType SignalBoxId PagePlugId ProcessID PageModeName String Bool | NewAnythingProcessConfirmArgs PagePlugId ProcessID - | RenderProcessExitArgs PageId ProcessID + | RenderProcessExitArgs PageId + | RenderProcessExitConfirmArgs PageId ProcessID | RenderProcessExceptionArgs PageId | NewTabArgs PageType PagePath [String] | AnythingViewOutputArgs String String (Maybe Int) AnythingKeyPressId | LocalInteractivebarExitArgs - | LocalOutputbarUpdateArgs PagePlugId String - | LocalStatusbarUpdateArgs PagePlugId String String - | LocalProgressUpdateArgs PagePlugId Double | SynchronizationPathNameArgs PageModeName PageId String | ChangeTabNameArgs PageModeName PageId String | SwitchBufferArgs PageModeName PageId | ShowTooltipArgs String (Maybe Point) Int (Maybe Color) (Maybe Color) Bool (Maybe PageId) | LocalInteractiveReturnArgs [String] | GlobalInteractiveReturnArgs [String] + | PingArgs ProcessID deriving (Show, Eq, Ord) data RenderMember = CloneRenderPage @@ -285,20 +284,26 @@ | AnythingViewChangeInteractiveType | UpdateConfig | InstallConfig + | Pong deriving (Show, Eq, Ord) data RenderSignalArgs = CloneRenderPageArgs PageId SignalBoxId | ReparentRenderPageArgs PageId PagePlugId SignalBoxId | FocusRenderPageArgs PagePlugId | PageViewKeyPressArgs PagePlugId Text SerializedEvent - | DestroyRenderPageArgs PageId PagePlugId + | DestroyRenderPageArgs PagePlugId | ExitRenderProcessArgs PageId | AnythingViewKeyPressArgs Text String String AnythingKeyPressId Bool | AnythingViewChangeCandidateArgs [String] | AnythingViewChangeInteractiveTypeArgs AnythingInteractiveType | UpdateConfigArgs | InstallConfigArgs + | PongArgs deriving (Show, Eq, Ord) + +data PongStatus = WaitPongMessage + | GotPongMessage + deriving (Show, Eq, Ord) data DaemonBroadcastMember = ExitDaemonProcess deriving (Show, Eq, Ord) diff --git a/Manatee/Toolkit/Gtk/Multiline.hs b/Manatee/Toolkit/Gtk/Multiline.hs --- a/Manatee/Toolkit/Gtk/Multiline.hs +++ b/Manatee/Toolkit/Gtk/Multiline.hs @@ -79,6 +79,25 @@ iter <- textBufferGetInsertIter buffer textBufferGetTagByteStringWithIter buffer iter tag +-- | Selection bound with line/row. +textBufferSelectBound :: TextBufferClass self => self -> (Int, Int) -> (Int, Int) -> IO () +textBufferSelectBound tb (insertLine, insertRow) (selectLine, selectRow) = do + -- Get temp iter. + iter <- textBufferGetStartIter tb + + -- Create insert iter. + insertIter <- textIterCopy iter + textIterSetLine insertIter insertLine + textIterSetLineOffset insertIter insertRow + + -- Create select iter. + selectIter <- textIterCopy iter + textIterSetLine selectIter selectLine + textIterSetLineOffset selectIter selectRow + + -- Select bound. + textBufferSelectRange tb insertIter selectIter + -- | Text buffer keep selection to execute action. textBufferKeepSelection :: TextBufferClass self => self -> Bool -> Bool -> IO () -> IO () textBufferKeepSelection tb sLeft eLeft action = do @@ -320,6 +339,12 @@ tb <- textViewGetBuffer tv iter <- textBufferGetIterAtMark tb tm textViewPlaceCursor tv iter + +-- | Get line count. +textViewGetLineCount :: TextViewClass self => self -> IO Int +textViewGetLineCount tv = do + tb <- textViewGetBuffer tv + textBufferGetLineCount tb -- | Goto line. -- If line number not in buffer bound, goto min/max line. diff --git a/Manatee/Toolkit/Gtk/ScrolledWindow.hs b/Manatee/Toolkit/Gtk/ScrolledWindow.hs --- a/Manatee/Toolkit/Gtk/ScrolledWindow.hs +++ b/Manatee/Toolkit/Gtk/ScrolledWindow.hs @@ -135,4 +135,28 @@ cr <- adjustmentGetValue aj return (cr >= up - ps) +-- | Get value. +scrolledWindowGetValue :: ScrolledWindowClass sw => sw -> IO (Double, Double) +scrolledWindowGetValue sw = do + hAdj <- scrolledWindowGetHAdjustment sw + vAdj <- scrolledWindowGetVAdjustment sw + hValue <- adjustmentGetValue hAdj + vValue <- adjustmentGetValue vAdj + return (hValue, vValue) + +-- | Set value. +scrolledWindowSetValue :: ScrolledWindowClass sw => sw -> (Double, Double) -> IO () +scrolledWindowSetValue sw (x, y) = do + hAdj <- scrolledWindowGetHAdjustment sw + vAdj <- scrolledWindowGetVAdjustment sw + adjustmentSetValue hAdj x + adjustmentSetValue vAdj y +-- | Get max size. +scrolledWindowGetSize :: ScrolledWindowClass sw => sw -> IO (Double, Double) +scrolledWindowGetSize sw = do + hAdj <- scrolledWindowGetHAdjustment sw + vAdj <- scrolledWindowGetVAdjustment sw + hSize <- adjustmentGetUpper hAdj + vSize <- adjustmentGetUpper vAdj + return (hSize, vSize) diff --git a/manatee-core.cabal b/manatee-core.cabal --- a/manatee-core.cabal +++ b/manatee-core.cabal @@ -1,5 +1,5 @@ name: manatee-core -version: 0.0.7 +version: 0.0.8 Cabal-Version: >= 1.6 license: GPL-3 license-file: LICENSE @@ -47,6 +47,7 @@ Manatee.Core.Interactive Manatee.Core.FileOpenRule Manatee.Core.Page + Manatee.Core.PageFrame Manatee.Core.PageMode Manatee.Core.PageView Manatee.Core.Config