-- 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 . {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Manatee.Daemon where import Control.Applicative hiding (empty) import Control.Arrow import Control.Concurrent.MVar import Control.Exception import Control.Monad import Control.Monad.Trans import DBus.Client hiding (Signal) import DBus.Types import Data.Map (Map, union) import Data.Text.Lazy (Text) import GHC.Conc import Graphics.UI.Gtk hiding (Window, windowNew, Frame, frameNew, Signal, Variant, Action, plugNew, plugGetId, get, Keymap) import Graphics.UI.Gtk.Gdk.SerializedEvent import Manatee.Action.Basic import Manatee.Action.BufferList import Manatee.Action.Tab import Manatee.Action.Tabbar import Manatee.Action.Window import Manatee.Core.Config import Manatee.Core.DBus import Manatee.Core.Debug import Manatee.Core.PageMode import Manatee.Core.Interactive import Manatee.Core.Types import Manatee.Environment import Manatee.Toolkit.General.Basic import Manatee.Toolkit.General.FilePath import Manatee.Toolkit.General.List import Manatee.Toolkit.General.Maybe import Manatee.Toolkit.General.Process import Manatee.Toolkit.General.STM import Manatee.Toolkit.General.Set hiding (mapM) import Manatee.Toolkit.Gio.Gio import Manatee.Toolkit.Gtk.Concurrent import Manatee.Toolkit.Gtk.Editable import Manatee.Toolkit.Gtk.Event import Manatee.Toolkit.Gtk.Gtk import Manatee.Toolkit.Gtk.Struct import Manatee.Toolkit.Widget.Interactivebar import Manatee.Toolkit.Widget.NotebookTab import Manatee.Toolkit.Widget.PopupWindow import Manatee.Toolkit.Widget.Tooltip import Manatee.Types import Manatee.UI.Frame import Manatee.UI.UIFrame import Manatee.UI.Window import System.Directory import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text.Lazy as T import qualified Data.Foldable as F import qualified Data.ByteString.UTF8 as UTF8 -- | Daemon process main entry. daemonMain :: IO () daemonMain = do -- Init. unsafeInitGUIForThreadedRTS env <- mkEnvironment let frame = envFrame env anythingBox = envInitBox env anythingInteractivebar = envInitInteractivebar env -- Build daemon client for listen dbus signal. mkDaemonClient env -- Build local object. mkDaemonMethods [("GetBufferList", callGetBufferList env) ,("Interactive", callGetInteractive env) ,("GetBufferHistory", callGetBufferHistory env)] -- Read extension global keymap. (ExtensionGloalKeymap keymap) <- readConfig extensionGlobalKeymapPath (ExtensionGloalKeymap M.empty) let extensionGlobalKeymap = M.fromList $ map (\ (key, (pType, pPath, pOptions)) -> (T.pack key, Action (newTab pType pPath pOptions))) (M.toList keymap) -- Handle key event. frame `on` keyPressEvent $ tryEvent $ do -- Remove tooltip when press key. liftIO $ do tList <- readTVarIO $ envTooltipSet env forM_ (Set.toList tList) (\x -> tooltipExit x (envTooltipSet env)) -- Focus tab when press key. liftIO $ focusTab env -- Get event status. focusStatus <- liftIO $ getFocusStatus env keystoke <- eventKeystoke sEvent <- serializedEvent -- liftIO $ do -- ((tabbar, bufferList) :: (Tabbar, BufferList)) <- envGet env -- putStrLn $ "-------------------------------" -- putStrLn $ "daemonMain bufferlist: " ++ groom bufferList -- putStrLn $ "daemonMain tabbar: " ++ groom tabbar -- liftIO $ do -- (windowList, tabbar) :: (WindowList, Tabbar) <- envGet env -- putStrLn $ "---------------------------" -- putStrLn $ "daemonMain WindowList : " ++ groom windowList -- putStrLn $ "daemonMain tabbar: " ++ groom tabbar -- liftIO $ putStrLn $ "Debug keystoke : " ++ show keystoke -- Handle key press event. liftIO $ do -- Handle global keymap first. case M.lookup keystoke (globalKeymap `union` extensionGlobalKeymap) of -- Execute global command. Just action -> runAction env action Nothing -> case focusStatus of -- Ignore localKeymap when handle init interactivebar. FocusInitInteractivebar -> handleInteractivebarKeyPress env keystoke anythingInteractivebar _ -> case M.lookup keystoke localKeymap of -- Execute local command. Just action -> runAction env action _ -> case focusStatus of -- Handle PageView keymap. FocusWindow -> envGet env >>= handlePageViewKeyPress keystoke sEvent -- Handle local interactivebar. FocusLocalInteractivebar -> getCurrentInteractivebar env >?>= handleInteractivebarKeyPress env keystoke -- Focus tab after handle event. focusTab env -- Init commander. anythingInitStartup frame anythingBox anythingInteractivebar -- Show. widgetShowAll frame frame `onDestroy` do -- Send broadcast quit signal, other process can listen this signal when daemon process quit. client <- envGet env mkDaemonBroadcastSignal client ExitDaemonProcess ExitDaemonProcessArgs -- Need exit all render processes before exit daemon process. exitAllRenderProcess env -- Exit daemon process. mainQuit -- Loop. mainGUI -- | Global keymap. globalKeymap :: Keymap globalKeymap = M.fromList ["F7" ==> startIrc ,"F11" ==> toggleFullscreen ,"F12" ==> lockScreen ,"C-'" ==> tabUndoCloseGlobal ,"C-\"" ==> tabUndoCloseLocal ,"M-A" ==> pausePlay ] -- | Interactivebar keymap. interactiveKeymap :: Map Text (Environment -> Entry -> IO ()) interactiveKeymap = M.fromList [("Tab", \ _ ed -> editableExpandCompletion ed) ,("BackSpace", \ _ ed -> editableDeleteBackwardChar ed) ,("M-,", \ _ ed -> editableDeleteBackwardChar ed) ,("M-<", \ _ ed -> editableDeleteBackwardWord ed) ,("M-d", \ _ ed -> editableDeleteAllText ed) ,("M-x", \ _ ed -> editableCutClipboard ed) ,("M-c", \ _ ed -> editableCopyClipboard ed) ,("M-v", interactivebarPasteClipboard) ] -- | Local keymap for extension. localKeymap :: Keymap localKeymap = M.fromList -- Window keymap. ["M-t" ==> windowSplitVertically ,"M-T" ==> windowSplitHortizontally ,"M-n" ==> windowSelectNext ,"M-p" ==> windowSelectPrev ,"M-;" ==> windowCloseCurrent ,"M-:" ==> windowCloseOthers -- Window zoom keymap. ,"P-." ==> windowEnlarge ,"P-," ==> windowShrink ,"P-j" ==> windowEnlargeDown ,"P-k" ==> windowEnlargeUp ,"P-h" ==> windowEnlargeLeft ,"P-l" ==> windowEnlargeRight ,"P-J" ==> windowShrinkDown ,"P-K" ==> windowShrinkUp ,"P-H" ==> windowShrinkLeft ,"P-L" ==> windowShrinkRight -- Tab keymap in current window. ,"M-9" ==> tabForwardGroup ,"M-0" ==> tabBackwardGroup ,"M-7" ==> tabSelectPrev ,"M-8" ==> tabSelectNext ,"M-&" ==> tabSelectFirst ,"M-*" ==> tabSelectLast ,"C-7" ==> tabMoveToLeft ,"C-8" ==> tabMoveToRight ,"C-&" ==> tabMoveToBegin ,"C-*" ==> tabMoveToEnd ,"M-'" ==> tabCloseCurrent ,"M-\"" ==> tabCloseOthers -- Tab keymap with next window. ,"P-7" ==> tabSelectPrevWithNextWindow ,"P-8" ==> tabSelectNextWithNextWindow ,"P-&" ==> tabSelectFirstWithNextWindow ,"P-*" ==> tabSelectLastWithNextWindow ,"P-9" ==> tabForwardGroupWithNextWindow ,"P-0" ==> tabBackwardGroupWithNextWindow ,"C-P-7" ==> tabMoveToLeftWithNextWindow ,"C-P-8" ==> tabMoveToRightWithNextWindow ,"C-P-&" ==> tabMoveToBeginWithNextWindow ,"C-P-*" ==> tabMoveToEndWithNextWindow -- Other keymap. ,"M-f" ==> focusInteractivebar ,"M-F" ==> focusCurrentTab ,"M-b" ==> focusSwitch ,"M-g" ==> exitInteractivebar ,"M-[" ==> viewBufferDirectory ] -- | Build daemon client for listen dbus signal. mkDaemonClient :: Environment -> IO () mkDaemonClient env = do let tabbar = envTabbar env client = envDaemonClient env mkDaemonMatchRules client [(NewRenderPageConfirm, daemonHandleNewPageConfirm env) ,(RenderProcessExit, daemonHandleRenderProcessExit) ,(NewTab, daemonHandleNewTab env) ,(NewAnythingProcessConfirm, daemonHandleNewAnythingProcessConfirm env) ,(AnythingViewOutput, daemonHandleAnythingViewOutput env) ,(LocalInteractivebarExit, daemonHandleLocalInteractivebarExit env) ,(LocalOutputbarUpdate, daemonHandleLocalOutputbarUpdate tabbar) ,(LocalStatusbarUpdate, daemonHandleLocalStatusbarUpdate tabbar) ,(LocalProgressUpdate, daemonHandleLocalProgressUpdate tabbar) ,(SynchronizationPathName, daemonHandleSynchronizationPathName env) ,(ChangeTabName, daemonHandleChangeTabName env) ,(SwitchBuffer, daemonHandleSwitchBuffer env) ,(ShowTooltip, daemonHandleShowTooltip env) ,(LocalInteractiveReturn, daemonHandleLocalInteractiveReturn env) ,(GlobalInteractiveReturn, daemonHandleGlobalInteractiveReturn env) ] -- | Handle render process exit signal. daemonHandleRenderProcessExit :: DaemonSignalArgs -> IO () daemonHandleRenderProcessExit (RenderProcessExitArgs pageId processId) = debugDBusMessage $ "daemonHandleRenderProcessExit: child process " ++ show processId ++ " exit. With page id : " ++ show pageId -- | Handle new tab signal. daemonHandleNewTab :: Environment -> DaemonSignalArgs -> IO () daemonHandleNewTab env (NewTabArgs pageType pagePath options) = runAction env (Action (newTab pageType pagePath options)) -- | Handle new anything process confirm signal. daemonHandleNewAnythingProcessConfirm :: Environment -> DaemonSignalArgs -> IO () daemonHandleNewAnythingProcessConfirm env (NewAnythingProcessConfirmArgs (GWindowId plugId) processId) = do let popupWindow = envAnythingPopupWindow env anythingBox = envInitBox env anythingProcessId = envAnythingProcessId env socket <- socketNew_ focusStatus <- getFocusStatus env case focusStatus of FocusInitInteractivebar -> anythingBox `containerAdd` socket _ -> popupWindowAdd popupWindow socket socketAddId socket plugId writeTVarIO anythingProcessId processId -- | Handle interactivebar input. daemonHandleAnythingViewOutput :: Environment -> DaemonSignalArgs -> IO () daemonHandleAnythingViewOutput env (AnythingViewOutputArgs input completion outputHeight keyPressId) = do -- Just update anything input entry status when -- return return keyPressId is same current one. -- Otherwise drop *old* calculation result. currentKeyPressId <- readTVarIO $ envAnythingKeyPressId env when (currentKeyPressId == keyPressId) $ do let interactivebar = envInitInteractivebar env popupWindow = envAnythingPopupWindow env focusStatus <- getFocusStatus env case focusStatus of FocusInitInteractivebar -> editableSetCompletionText (interactivebarEntry interactivebar) input completion _ -> getCurrentInteractivebar env >?>= \ bar -> do -- Set entry. editableSetCompletionText (interactivebarEntry bar) input completion case outputHeight of -- Adjust popup window with special size and position. Just height -> do let adjustHeight | height < popupWindowDefaultHeight = height | otherwise = popupWindowDefaultHeight -- Get size of interactivebar. (Rectangle x y w h) <- widgetGetAllocation (interactivebarEntry bar) -- Get size of screen. (_, screenHeight) <- widgetGetScreenSize (interactivebarEntry bar) -- If interactivebar's position too low, display popup window at above of interactivebar. -- Otherwise, at below of interactivebar. let adjustY | y + h + popupWindowDefaultHeight > screenHeight = y - adjustHeight | otherwise = y + h popupWindowSetAllocation popupWindow (Rectangle x adjustY w adjustHeight) popupWindowShow popupWindow -- Hide popup window when no output need to display. Nothing -> popupWindowHide popupWindow -- | Handle local interactivebar exit. daemonHandleLocalInteractivebarExit :: Environment -> DaemonSignalArgs -> IO () daemonHandleLocalInteractivebarExit env LocalInteractivebarExitArgs = do focusStatus <- getFocusStatus env unless (focusStatus == FocusInitInteractivebar) $ exitInteractivebar env -- | Handle local outputbar update. daemonHandleLocalOutputbarUpdate :: TVar Tabbar -> DaemonSignalArgs -> IO () daemonHandleLocalOutputbarUpdate tabbar (LocalOutputbarUpdateArgs plugId output) = tabUpdateOutput tabbar plugId output -- | Handle local statusbar update. daemonHandleLocalStatusbarUpdate :: TVar Tabbar -> DaemonSignalArgs -> IO () daemonHandleLocalStatusbarUpdate tabbar (LocalStatusbarUpdateArgs plugId item status) = tabUpdateStatus tabbar plugId item status -- | Handle local statusbar update. daemonHandleLocalProgressUpdate :: TVar Tabbar -> DaemonSignalArgs -> IO () daemonHandleLocalProgressUpdate tabbar (LocalProgressUpdateArgs plugId progress) = tabUpdateProgress tabbar plugId progress -- | Handle synchronization tab name. daemonHandleSynchronizationPathName :: Environment -> DaemonSignalArgs -> IO () daemonHandleSynchronizationPathName env (SynchronizationPathNameArgs modeName pageId path) = do debugDBusMessage $ "daemonHandleSynchronizationPathName: Catch SynchronizationPathName signal. Page id : " ++ show pageId (bufferListTVar, Tabbar tabbar) <- envGet env -- Replace path name. modifyTVarIO bufferListTVar (bufferListReplacePath modeName pageId path) -- Adjust tab name. pageModeDuplicateTabList <- getDuplicateTabList modifyTVarIO bufferListTVar (if modeName `elem` pageModeDuplicateTabList -- Just strip tab name when current page mode in 'pageModeDuplicateTabList' then bufferListStripName modeName pageId path -- Otherwise unique all tab names. else bufferListUniqueName modeName) -- Update notebook name. forM_ (M.toList tabbar) $ \ ((windowId, pageModeName), _) -> when (pageModeName == modeName) $ syncTabName env windowId -- | Handle synchronization tab name. daemonHandleChangeTabName :: Environment -> DaemonSignalArgs -> IO () daemonHandleChangeTabName env (ChangeTabNameArgs modeName pageId path) = do debugDBusMessage $ "daemonHandleChangeTabName: Catch SynchronizationPathName signal. Page id : " ++ show pageId (bufferListTVar, Tabbar tabbar) <- envGet env -- Replace tab name. modifyTVarIO bufferListTVar (bufferListReplaceName modeName pageId path) -- Update notebook name. forM_ (M.toList tabbar) $ \ ((windowId, pageModeName), _) -> when (pageModeName == modeName) $ syncTabName env windowId -- | Handle switch buffer. daemonHandleSwitchBuffer :: Environment -> DaemonSignalArgs -> IO () daemonHandleSwitchBuffer env (SwitchBufferArgs modeName pageId) = do -- Switch to buffer if it has exist. bufferList <- envGet env bufferListGetBufferIndexWithId bufferList modeName pageId ?>= \ i -> do tabSwitchGroupCurrentWindow env modeName window <- envGet env notebookSetCurrentPage (windowNotebook window) i -- | Handle InteractiveReturn return. daemonHandleLocalInteractiveReturn :: Environment -> DaemonSignalArgs -> IO () daemonHandleLocalInteractiveReturn env (LocalInteractiveReturnArgs strList) = do popupWindow <- envGet env focusStatus <- getFocusStatus env unless (focusStatus == FocusInitInteractivebar) $ do -- Get track value. track <- readTVarIO (envLocalInteractiveTrack env) -- Update return value. modifyTVarIO (envLocalInteractiveReturn env) (++ strList) if length track <= 1 -- Exit interactivebar when user input complete. then do returnList <- readTVarIO (envLocalInteractiveReturn env) tryPutMVar (envLocalInteractiveLock env) (Right returnList) exitInteractivebar env -- Or update track value and input next. else do let restTrack = tail track (interactiveName, interactiveTitle) = head restTrack -- Update track value. writeTVarIO (envLocalInteractiveTrack env) restTrack -- Reset interactivebar and popup window. getCurrentUIFrame env >?>= \uiFrame -> do let interactivebar = uiFrameInteractivebar uiFrame interactivebarSetTitle interactivebar interactiveTitle interactivebarSetContent interactivebar "" -- Hide popup window. popupWindowSetAllocation popupWindow (Rectangle 0 0 1 1) -- Change anything view candidate. processId <- readTVarIO $ envAnythingProcessId env mkRenderSignal (envDaemonClient env) processId AnythingViewChangeCandidate (AnythingViewChangeCandidateArgs [interactiveName]) -- | Handle InteractiveReturn return. daemonHandleGlobalInteractiveReturn :: Environment -> DaemonSignalArgs -> IO () daemonHandleGlobalInteractiveReturn env (GlobalInteractiveReturnArgs strList) = do -- Get popup window and focus status. popupWindow <- envGet env focusStatus <- getFocusStatus env -- Get track value. track <- readTVarIO (envGlobalInteractiveTrack env) -- Update return value. modifyTVarIO (envGlobalInteractiveReturn env) (++ strList) if length track <= 1 -- Exit interactivebar when user input complete. then do returnList <- readTVarIO (envGlobalInteractiveReturn env) tryPutMVar (envGlobalInteractiveLock env) (Right returnList) unless (focusStatus == FocusInitInteractivebar) $ exitInteractivebar env -- Or update track value and input next. else do -- Get interactive name and title. let restTrack = tail track (interactiveName, interactiveTitle) = head restTrack -- Update track value. writeTVarIO (envGlobalInteractiveTrack env) restTrack -- Reset interactivebar and popup window. case focusStatus of FocusInitInteractivebar -> do -- Show init interactivebar. let interactivebar = envInitInteractivebar env interactivebarSetTitle interactivebar interactiveTitle interactivebarSetContent interactivebar "" _ -> getCurrentUIFrame env >?>= \uiFrame -> do -- Show local interactivebar. let interactivebar = uiFrameInteractivebar uiFrame interactivebarSetTitle interactivebar interactiveTitle interactivebarSetContent interactivebar "" -- Hide popup window. popupWindowSetAllocation popupWindow (Rectangle 0 0 1 1) -- Change anything view candidate. processId <- readTVarIO $ envAnythingProcessId env mkRenderSignal (envDaemonClient env) processId AnythingViewChangeCandidate (AnythingViewChangeCandidateArgs [interactiveName]) -- | Handle switch buffer. daemonHandleShowTooltip :: Environment -> DaemonSignalArgs -> IO () daemonHandleShowTooltip env (ShowTooltipArgs text point int foreground background hideWhenPress pageId) = do -- Init. tooltipId <- tickTVarIO (envTooltipCounter env) let showTooltip p = tooltipNew tooltipId (envFrame env) text p int foreground background hideWhenPress (envTooltipSet env) -- Just add in set when tooltip will hide after press key. >>= \tooltip -> when hideWhenPress $ modifyTVarIO (envTooltipSet env) (Set.insert tooltip) -- Get current tab. focusStatus <- liftIO $ getFocusStatus env currentTab <- case focusStatus of FocusInitInteractivebar -> return Nothing _ -> getCurrentTab env -- Show tooltip. case currentTab of -- Show tooltip when current no window exist. Nothing -> showTooltip point Just (Tab {tabPageId = tpId ,tabUIFrame = UIFrame {uiFrameFrame = frame}}) -> do -- Translate UIFrame coordinate to top-level coordinate. (Rectangle fx fy _ _) <- widgetGetAllocation frame let tooltipPoint = fmap ((+) fx *** (+) fy) point case pageId of -- Show tooltip directly when no pageId information in DBus signal. Nothing -> showTooltip tooltipPoint -- Or just show tooltip when user not at same page as signal from. Just pId -> when (tpId /= pId) $ showTooltip tooltipPoint -- | Handle new page confirm signal. daemonHandleNewPageConfirm :: Environment -> DaemonSignalArgs -> IO () daemonHandleNewPageConfirm env args@(NewRenderPageConfirmArgs pageId pType sId plugId processId modeName path isFirstPage) = do (tabbarTVar, (bufferListTVar, (signalBoxList, windowList))) <- envGet env -- Debug. -- putStrLn $ "Page id : " ++ show pageId ++ -- "\nPage plug id : " ++ show plugId ++ -- "\nProcess id : " ++ show processId ++ -- "\nMode name : " ++ modeName ++ -- "\nPath : " ++ path -- Get signal box. sbList <- readTVarIO signalBoxList case (maybeFindMin sbList (\x -> signalBoxId x == sId)) of Nothing -> putStrLn $ "### Impossible: daemonHandleNewPageConfirm - Can't find signal box Id " ++ show sId Just signalBox -> do -- Get window id that socket add. let windowId = signalBoxWindowId signalBox -- Add page. debugDBusMessage $ "daemonHandleNewPageConfirm: Catch NewRenderPageConfirm signal. Box id : " ++ show sId debugDBusMessage "------------------------------" -- Add plug to socket. let uiFrame = signalBoxUIFrame signalBox notebookTab = uiFrameNotebookTab uiFrame socketId <- socketFrameAdd uiFrame plugId modeName -- Stop spinner animation. notebookTabStop notebookTab -- Close current page when click close button. ntCloseButton notebookTab `onToolButtonClicked` do -- Focus window container close button first, -- otherwise `tabClose` can't work. modifyTVarIO windowList (`windowListFocusId` windowId) tabClose env pageId -- Update buffer list when first page create. when isFirstPage $ do -- Add new buffer. modifyTVarIO bufferListTVar (bufferListAddBuffer (modeName, processId, pageId, pType, path)) -- Adjust tab name. pageModeDuplicateTabList <- getDuplicateTabList modifyTVarIO bufferListTVar (if modeName `elem` pageModeDuplicateTabList -- Just strip tab name when current page mode in 'pageModeDuplicateTabList' then bufferListStripName modeName pageId path -- Otherwise unique all tab names. else bufferListUniqueName modeName) -- Update buffer history. bufferList <- readTVarIO bufferListTVar bufferListGetBuffer bufferList modeName pageId ?>= \ Buffer {bufferPageType = pageType ,bufferPath = path} -> modifyTVarIO (envBufferHistory env) (insertUnique (BufferHistory modeName pageType path)) -- Update tabbar. modifyTVarIO tabbarTVar (tabbarAddTab windowId modeName (Tab processId pageId socketId plugId uiFrame)) -- Synchronization tab name. syncTabName env windowId -- Delete corresponding SignalBox from SignalBoxList. writeTVarIO signalBoxList (Set.delete signalBox sbList) -- Synchronization tab in all window when first page create. when isFirstPage $ tabbarSyncNewTab env windowId args -- | Add socket to socket frame. socketFrameAdd :: UIFrame -> PagePlugId -> PageModeName -> IO PageSocketId socketFrameAdd uiFrame (GWindowId plugId) modeName = do -- Add plug in UIFrame. let socketFrame = uiFrameFrame uiFrame socket <- socketNew_ socketFrame `containerAdd` socket socketAddId socket plugId -- Update page mode status in UIFrame. uiFrameUpdateStatusbar uiFrame "PageMode" ("Mode (" ++ modeName ++ ")") GWindowId <$> socketGetId socket -- | Return buffer history. callGetBufferHistory :: Environment -> Member callGetBufferHistory env = Method "" "s" $ \ call -> do history <- readTVarIO $ envBufferHistory env replyReturn call [toVariant history] -- | Return buffer list. callGetBufferList :: Environment -> Member callGetBufferList env = Method "" "s" $ \ call -> do (BufferList bufferList) <- readTVarIO $ envBufferList env let list = concatMap (\ (modeName, bufferSeq) -> map (\ Buffer {bufferPageId = pageId ,bufferPath = path ,bufferName = name} -> BufferInfo modeName path name pageId) $ F.toList bufferSeq) $ M.toList bufferList -- Don't return current buffer. focusStatus <- liftIO $ getFocusStatus env currentPageId <- case focusStatus of FocusInitInteractivebar -> return Nothing _ -> tabGetCurrentPageId env let bufferInfos = case currentPageId of Just pId -> filter (\ x -> bufferInfoId x /= pId) list Nothing -> list replyReturn call [toVariant bufferInfos] -- | Return interactive [String]. callGetInteractive :: Environment -> Member callGetInteractive env = Method "s" "s" $ \ call -> do -- Get input arguments. (tabbar, popupWindow) <- envGet env let Just input = fromVariant (head $ methodCallBody call) (plugId, inputStr) = read input :: (PagePlugId, String) case parseInteractiveString inputStr of -- Return error if parse interactive string failed. Left err -> replyLocalInteractiveError call err Right list -> do -- Init track and return value. writeTVarIO (envLocalInteractiveTrack env) list writeTVarIO (envLocalInteractiveReturn env) [] -- Empty interactive lock first. tryTakeMVar (envLocalInteractiveLock env) postGUIAsync $ tabbarGetTab plugId tabbar ?>= \ Tab {tabUIFrame = uiFrame} -> do let interactivebar = uiFrameInteractivebar uiFrame interactiveName = (fst . head) list title = (snd . head) list -- Show interactivebar. uiFrameInit uiFrame title "" -- When PopupWindow is invisible startup anythingView process. whenM (not <$> popupWindowIsVisible popupWindow) (do -- Activate popup window. popupWindowActivate popupWindow interactivebar -- Start anything process. startupAnything (SpawnAnythingProcessArgs (InteractiveSearchArgs LocalInteractive [interactiveName]))) -- Wait interactive result. result <- takeMVar (envLocalInteractiveLock env) -- Return. case result of Left err -> replyLocalInteractiveError call err Right res -> replyReturn call [toVariant res] -- | Global interactive. globalInteractive :: Environment -> String -> ([String] -> IO ()) -> IO () globalInteractive env inputStr action = case parseInteractiveString inputStr of -- Return error if parse interactive string failed. Left err -> putStrLn $ "globalInteractive : parse interactive string failed : " ++ show err Right strList -> do -- Get popup window and focus status. popupWindow <- envGet env focusStatus <- getFocusStatus env -- Init track and return value. writeTVarIO (envGlobalInteractiveTrack env) strList writeTVarIO (envGlobalInteractiveReturn env) [] -- Empty interactive lock first. tryTakeMVar (envGlobalInteractiveLock env) -- Get interactive name and title. let (interactiveName, interactiveTitle) = head strList case focusStatus of FocusInitInteractivebar -> do -- Show interactivebar. let interactivebar = envInitInteractivebar env interactivebarSetTitle interactivebar interactiveTitle interactivebarSetContent interactivebar "" -- Change interactive type. let client = envDaemonClient env processId <- readTVarIO $ envAnythingProcessId env mkRenderSignal client processId AnythingViewChangeInteractiveType (AnythingViewChangeInteractiveTypeArgs GlobalInteractive) -- Change candidate. mkRenderSignal client processId AnythingViewChangeCandidate (AnythingViewChangeCandidateArgs [interactiveName]) _ -> getCurrentUIFrame env >?>= \uiFrame -> do -- Show interactivebar. let interactivebar = uiFrameInteractivebar uiFrame uiFrameInit uiFrame interactiveTitle "" -- When PopupWindow is invisible startup anythingView process. whenM (not <$> popupWindowIsVisible popupWindow) (do -- Activate popup window. popupWindowActivate popupWindow interactivebar -- Start anything process. startupAnything (SpawnAnythingProcessArgs (InteractiveSearchArgs GlobalInteractive [interactiveName]))) -- Wait interactive result. forkGuiIO_ (takeMVar (envGlobalInteractiveLock env)) (\ result -> case result of Left err -> putStrLn $ "globalInteractive : " ++ show err Right list -> -- Just do action if return list match. when (length strList == length list) $ bracketOnError (return list) -- Print error message if exception rasied when do action. (\ _ -> putStrLn "globalInteractive: exception rasied.") action) -- | Reply interactive error. replyLocalInteractiveError :: MethodCall -> Text -> IO () replyLocalInteractiveError call err = replyError call (mkErrorName_ daemonInteractiveErrorName) [toVariant err] -- | Handle page view key press event. handlePageViewKeyPress :: Text -> SerializedEvent -> (Environment, Client) -> IO () handlePageViewKeyPress keystoke sEvent (env, client) = getCurrentTab env >?>= \ Tab {tabProcessId = processId ,tabPlugId = plugId} -> mkRenderSignal client processId PageViewKeyPress (PageViewKeyPressArgs plugId keystoke sEvent) -- | Handle interactivebar key press event. handleInteractivebarKeyPress :: Environment -> Text -> Interactivebar -> IO () handleInteractivebarKeyPress env keystoke bar = do -- Get entry. let entry = interactivebarEntry bar -- Focus anything input entry. editableFocus entry -- Do action. isChanged <- editableIsChanged entry $ case M.lookup keystoke interactiveKeymap of Just action -> action env entry _ -> -- Insert character. when (T.length keystoke == 1) $ do unselectText <- editableGetUnselectText entry editableSetText entry (unselectText ++ T.unpack keystoke) -- Send key press signal. sendAnythingViewKeyPress env entry keystoke isChanged -- | Paste clipboard to interactivebar. interactivebarPasteClipboard :: Environment -> Entry -> IO () interactivebarPasteClipboard env ed = do clipboard <- widgetGetClipboard ed selectionClipboard clipboardRequestText clipboard $ \ text -> text ?>= \ content -> do -- Paste data from clipboard. pos <- editableGetPosition ed editableInsertText ed content pos editableSetPosition ed (pos + length content) -- Send key press signal. sendAnythingViewKeyPress env ed "" True -- | Send anything key press. sendAnythingViewKeyPress :: EditableClass ed => Environment -> ed -> Text -> Bool -> IO () sendAnythingViewKeyPress env entry keystoke isChanged = do -- Get client. let client = envDaemonClient env -- Get input string. allText <- editableGetAllText entry unselectText <- editableGetUnselectText entry -- Get anything process. processId <- readTVarIO $ envAnythingProcessId env -- Get keyPressId for identify anything process. keyPressId <- tickTVarIO $ envAnythingKeyPressId env -- Send signal to anything process. mkRenderSignal client processId AnythingViewKeyPress (AnythingViewKeyPressArgs keystoke allText unselectText keyPressId isChanged) -- | View buffer directory. -- If buffer path is not directory, view current directory. viewBufferDirectory :: Environment -> IO () viewBufferDirectory env = do (bufferList, (tabbar, window)) <- envGet env getCurrentTab env >?>= \ tab -> tabbarGetPageModeName tabbar (windowGetId window) ?>= \modeName -> bufferListGetBuffer bufferList modeName (tabPageId tab) ?>= \buffer -> do let path = getUpperDirectory $ bufferPath buffer if not (null path) && directoryDoesExist (UTF8.fromString path) then newTab "PageFileManager" path [] env else do currentDir <- getCurrentDirectory newTab "PageFileManager" currentDir [] env -- | Lock screen. lockScreen :: Environment -> IO () lockScreen _ = do -- Don't burn LCD power. (runCommand_ "xset dpms force off && sleep 1") -- Lock screen. (runCommand_ "xtrlock") -- | Play/Pause mplayer. pausePlay :: Environment -> IO () pausePlay env = mkGenericDaemonSignal (envDaemonClient env) "mplayer" Generic (GenericArgs "Pause" []) -- | Start irc. startIrc :: Environment -> IO () startIrc env = globalInteractive env "sServer : \nnPort : \nsChannel : \nsUserName : \n" $ \ [server, port, channel, user] -> do let info = "irc://" ++ user ++ "@" ++ server ++ ":" ++ port ++ "/" ++ channel mkDaemonSignal (envDaemonClient env) NewTab (NewTabArgs "PageIrc" info [])