module Manatee.Core.Render where
import Control.Monad.State
import DBus.Client hiding (Signal)
import GHC.Conc
import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Frame, Variant, Action, plugNew, plugGetId, get)
import Manatee.Core.DBus
import Manatee.Core.Debug
import Manatee.Core.Page
import Manatee.Core.PageView
import Manatee.Core.Types
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.Set hiding (mapM)
import Manatee.Toolkit.General.State
import Manatee.Toolkit.Widget.Plug
import System.Environment
import System.Posix.Process
import System.Posix.Types (ProcessID)
import qualified Data.Map as M
import qualified Data.Set as Set
startupRender :: PageBufferNewFun -> IO ()
startupRender bufferNewFun = do
args <- getArgs
case args of
[x] ->
case (read x :: SpawnProcessArgs) of
arg@(SpawnRenderProcessArgs {}) -> renderMain arg bufferNewFun
_ -> return ()
_ -> return ()
renderMain :: SpawnProcessArgs -> PageBufferNewFun -> IO ()
renderMain (SpawnRenderProcessArgs pageId pType sId pagePath) bufferNewFun = do
unsafeInitGUIForThreadedRTS
pageList <- newTVarIO Set.empty
processId <- getProcessID
let clientName = mkRenderClientName processId
client <- mkSessionClientWithName clientName
bufferWrap <- bufferNewFun pagePath client pageId
mkRenderClient client bufferWrap processId pageList pType
renderPageNew client bufferWrap pageList processId (pageId, pType, sId) True
mainGUI
mkRenderClient :: Client -> PageBufferWrap -> ProcessID -> TVar PageList -> PageType -> IO ()
mkRenderClient client bufferWrap processId pageList pType =
mkRenderMatchRules client
[(CloneRenderPage, renderHandleClonePage client bufferWrap pageList processId pType)
,(ReparentRenderPage, renderHandleReparentPage client bufferWrap pageList processId)
,(FocusRenderPage, renderHandleFocusPage pageList)
,(PageViewKeyPress, renderHandleKeyPress pageList)
,(DestroyRenderPage, renderHandleDestroyPage pageList)
,(ExitRenderProcess, renderHandleExitProcess client processId)]
renderHandleClonePage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> PageType -> RenderSignalArgs -> IO ()
renderHandleClonePage client bufferWrap pageList processId pType (CloneRenderPageArgs pageId sId) = do
debugDBusMessage $ "renderHandleClonePage: Catch CloneRenderPage signal. Box id: " ++ show sId
renderPageNew client bufferWrap pageList processId (pageId, pType, sId) False
debugDBusMessage $ "renderHandleClonePage: Finish clone page. Box id : " ++ show sId
renderHandleReparentPage :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> RenderSignalArgs -> IO ()
renderHandleReparentPage client (PageBufferWrap buffer) pageList processId (ReparentRenderPageArgs pageId oldPlugId sId) = do
debugDBusMessage $ "renderHandleReparentPage: Catch ReparentRenderPage signal. Box id: " ++ show sId
pList <- readTVarIO pageList
let oldPage = maybeFindMin pList (\x -> pagePlugId x == oldPlugId)
case oldPage of
Just op -> do
newPlug <- plugNew Nothing
let pId = plugId newPlug
pType = pageType op
writeTVarIO (pageApplyViewWrap op pageViewPlugId) pId
widgetReparent (pageScrolledWindow op) (plugBody newPlug)
widgetShowAll $ plugBody newPlug
page <- pageNew pageId pType newPlug (pageView op)
runTVarStateT pageList $ put . Set.insert page
renderHandleDestroyPage pageList (DestroyRenderPageArgs pageId oldPlugId)
let modeName = pageModeName $ pageBufferMode buffer
path <- pageBufferGetName buffer
mkDaemonSignal client
NewRenderPageConfirm
(NewRenderPageConfirmArgs pageId pType sId pId processId modeName path False)
debugDBusMessage $ "renderHandleReparentPage: Finish reparent page. Box id : " ++ show sId
Nothing -> debugDBusMessage $ "Warning (renderHandleReparentPage): Cant find old plug " ++ show oldPlugId ++ " to reparent."
renderPageNew :: Client -> PageBufferWrap -> TVar PageList -> ProcessID -> (PageId, PageType, SignalBoxId) -> Bool -> IO ()
renderPageNew client (PageBufferWrap buffer) pageList processId (pageId, pType, sId) isFirstPage = do
plug <- plugNew Nothing
let pId = plugId plug
viewWrap <- pageBufferCreateView buffer pId
page <- pageNew pageId pType plug viewWrap
plugBody plug `containerAdd` pageScrolledWindow page
widgetShowAll $ plugBody plug
runTVarStateT pageList $ put . Set.insert page
let modeName = pageModeName $ pageBufferMode buffer
path <- pageBufferGetName buffer
mkDaemonSignal client
NewRenderPageConfirm
(NewRenderPageConfirmArgs pageId pType sId pId processId modeName path isFirstPage)
renderHandleFocusPage :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleFocusPage pageList (FocusRenderPageArgs plugId) = do
pl <- readTVarIO pageList
maybeFindMin pl (\x -> pagePlugId x == plugId)
?>= \ page -> pageApplyViewWrap page pageViewFocus
renderHandleKeyPress :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleKeyPress pageList (PageViewKeyPressArgs plugId keystoke sEvent) = do
pl <- readTVarIO pageList
maybeFindMin pl (\x -> pagePlugId x == plugId)
?>= \ (Page {pageView = PageViewWrap view}) ->
case M.lookup keystoke pageViewKeymap of
Just action -> action view
Nothing -> pageViewHandleKeyAction view keystoke sEvent
renderHandleDestroyPage :: TVar PageList -> RenderSignalArgs -> IO ()
renderHandleDestroyPage pageList (DestroyRenderPageArgs _ plugId) =
runTVarStateT pageList $ \pl ->
maybeFindMin pl (\x -> pagePlugId x == plugId) ?>= \mp -> do
lift $ debugDBusMessage $ "renderHandleDestroyPage: Catch DestroyRenderPage signal. Plug id : " ++ show plugId
put (Set.delete mp pl)
lift $ plugDestroy $ pagePlug mp
renderHandleExitProcess :: Client -> ProcessID -> RenderSignalArgs -> IO ()
renderHandleExitProcess client processId (ExitRenderProcessArgs pageId) = do
mkDaemonSignal client RenderProcessExit (RenderProcessExitArgs pageId processId)
mainQuit