{-# LANGUAGE ForeignFunctionInterface #-} ---------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) Jan Vornberger 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : jan.vornberger@informatik.uni-oldenburg.de -- Stability : unstable -- Portability : not portable -- ----------------------------------------------------------------------------- module Main where import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade import Control.Concurrent import Control.Monad(when, forM_) import qualified Graphics.X11.Xlib as X import qualified Graphics.X11.Xlib.Extras as XE import System.Environment import System.IO import System.FilePath import Paths_bluetile import Utils import Data.IORef import Data.Maybe import Foreign import Foreign.C.Types import Unsafe.Coerce(unsafeCoerce) foreign import ccall "set_strut_properties" c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> () setStrutProperties :: Window -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) -> IO () setStrutProperties gtkWindow (left, right, top, bottom, left_start_y, left_end_y, right_start_y, right_end_y, top_start_x, top_end_x, bottom_start_x, bottom_end_x) = do let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window let fi = fromIntegral withForeignPtr ptrWin $ \realPointer -> do return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom) (fi left_start_y) (fi left_end_y) (fi right_start_y) (fi right_end_y) (fi top_start_x) (fi top_end_x) (fi bottom_start_x) (fi bottom_end_x) data DockOutput = DO Int String String | InternalQuitCmd deriving (Show, Read) nextScreenCmdOffset :: Int nextScreenCmdOffset = 18 incMasterCmd :: Int incMasterCmd = 16 decMasterCmd :: Int decMasterCmd = 17 quitBluetileCmd :: Int quitBluetileCmd = 18 quitBluetileStartMetacityCmd :: Int quitBluetileStartMetacityCmd = 19 -- name of widget caption identifier group command to execute tbData :: [(String, String, String, String, ToggleButton -> Int -> IORef Bool -> IO ())] tbData = [ ("togglebutton1" , "1", "1" , "workspace", sendCommandIfToggled 2) , ("togglebutton2" , "2", "2" , "workspace", sendCommandIfToggled 3) , ("togglebutton3" , "3", "3" , "workspace", sendCommandIfToggled 4) , ("togglebutton4" , "4", "4" , "workspace", sendCommandIfToggled 5) , ("togglebutton5" , "5", "5" , "workspace", sendCommandIfToggled 6) , ("togglebutton6" , "6", "6" , "workspace", sendCommandIfToggled 7) , ("togglebutton7" , "7", "7" , "workspace", sendCommandIfToggled 8) , ("togglebutton8" , "8", "8" , "workspace", sendCommandIfToggled 9) , ("togglebutton9" , "9", "9" , "workspace", sendCommandIfToggled 10) , ("togglebutton0" , "0", "0" , "workspace", sendCommandIfToggled 11) , ("togglebuttonlayouta", "A", "Floating" , "layout" , sendCommandIfToggled 12) , ("togglebuttonlayoutb", "S", "Tiled1" , "layout" , sendCommandIfToggled 13) , ("togglebuttonlayoutc", "D", "Tiled2" , "layout" , sendCommandIfToggled 14) , ("togglebuttonlayoutd", "F", "Fullscreen", "layout" , sendCommandIfToggled 15) ] main :: IO () main = do args <- getArgs let myScreenId = if (length args > 0 && head args == "--otherscreen") then 1 else 0 lockSendCommand <- newIORef False otherDockProcess <- newIORef Nothing -- prepare GUI initGUI dataDir <- getDataDir Just xml <- xmlNew $ dataDir "bluetiledock" "bluetiledock.glade" Just dfltScreen <- screenGetDefault dfltWh <- screenGetWidth dfltScreen -- monitor0 dock monitor0Dock <- xmlGetWidget xml castToWindow "monitor0Dock" windowSetTypeHint monitor0Dock WindowTypeHintDock onDestroy monitor0Dock mainQuit (m0DockWh, m0DockHt) <- windowGetSize monitor0Dock configBtn <- xmlGetWidget xml castToButton "configbutton" quitBtn <- xmlGetWidget xml castToButton "quitbutton" let m0DockY = 35 if myScreenId == 0 then do windowMove monitor0Dock 0 m0DockY onRealize monitor0Dock $ setStrutProperties monitor0Dock (m0DockWh + 1, 0, 0, 0, m0DockY, m0DockY + m0DockHt, 0, 0, 0, 0, 0, 0) return () else do windowMove monitor0Dock (dfltWh - m0DockWh) m0DockY onRealize monitor0Dock $ setStrutProperties monitor0Dock (0, m0DockWh + 1, 0, 0, 0, 0, m0DockY, m0DockY + m0DockHt, 0, 0, 0, 0) widgetSetSensitivity quitBtn False return () widgetShowAll monitor0Dock -- toggle buttons forM_ tbData $ \(tbName, tbCaption, _, _, f) -> do widget <- getTogglebutton xml tbName buttonSetLabel widget tbCaption onToggled widget (f widget myScreenId lockSendCommand) -- master area buttons incMasterBtn <- xmlGetWidget xml castToButton "incmasterbutton" decMasterBtn <- xmlGetWidget xml castToButton "decmasterbutton" onClicked incMasterBtn $ sendCommand incMasterCmd myScreenId onClicked decMasterBtn $ sendCommand decMasterCmd myScreenId -- config button onClicked configBtn $ do home <- getEnv "HOME" let userConfig = home ".bluetilerc" spawnPipe $ "gnome-open " ++ userConfig return () -- quit button onClicked quitBtn $ do dialog <- messageDialogNew (Just monitor0Dock) [DialogModal] MessageQuestion ButtonsNone "Really quit Bluetile?" dialogAddButton dialog "Quit" (ResponseUser quitBluetileCmd) dialogAddButton dialog "Quit and start Metacity" (ResponseUser quitBluetileStartMetacityCmd) dialogAddButton dialog "Cancel" ResponseCancel resp <- dialogRun dialog widgetDestroy dialog case resp of ResponseUser cmd -> do sendCommand cmd myScreenId hndlM <- readIORef otherDockProcess when (isJust hndlM) $ do hPutStrLn (fromJust hndlM) $ show InternalQuitCmd mainQuit _ -> return () -- prepare stdin reader updates <- getContents forkIO $ processUpdate (lines updates) xml myScreenId lockSendCommand otherDockProcess -- enter main GUI loop timeoutAddFull (yield >> return True) priorityDefaultIdle 50 mainGUI getTogglebutton :: GladeXML -> String -> IO (ToggleButton) getTogglebutton xml tbName = xmlGetWidget xml castToToggleButton tbName processUpdate :: [String] -> GladeXML -> Int -> IORef Bool -> IORef (Maybe Handle) -> IO () processUpdate updates xml myScreenId lockSendCommand otherDockProcess = mapM_ (pU . read) updates where pU :: DockOutput -> IO () pU update@(DO sid longLayoutDesc cws) = do let layoutDesc = last $ words longLayoutDesc hndlM <- readIORef otherDockProcess when (sid == myScreenId) $ do writeIORef lockSendCommand True activateToggleButtons xml cws "workspace" activateToggleButtons xml layoutDesc "layout" writeIORef lockSendCommand False when (sid /= myScreenId && isNothing hndlM) $ do libexecDir <- getLibexecDir hndl <- spawnPipe $ libexecDir "bluetiledock --otherscreen" writeIORef otherDockProcess (Just hndl) hPutStrLn hndl $ show update when (sid /= myScreenId && isJust hndlM) $ do hPutStrLn (fromJust hndlM) $ show update pU InternalQuitCmd = mainQuit activateToggleButtons :: GladeXML -> String -> String -> IO () activateToggleButtons xml cws group = do let relevantTbData = filter (\(_, _, _, group', _) -> group' == group) tbData forM_ relevantTbData $ \(tbName, _, tag, _, _) -> do widget <- getTogglebutton xml tbName toggleButtonSetActive widget (tag == cws) sendCommandIfToggled :: (ToggleButtonClass self) => Int -> self -> Int -> IORef Bool -> IO () sendCommandIfToggled cmd widget myScreenId lockSendCommand = do isToggled <- toggleButtonGetActive widget isLocked <- readIORef lockSendCommand when (isToggled && not isLocked) $ sendCommand cmd myScreenId sendCommand :: Int -> Int -> IO () sendCommand cmd myScreenId = sendCommandX (cmd + myScreenId * nextScreenCmdOffset) sendCommandX :: Int -> IO () sendCommandX com = do d <- X.openDisplay "" rw <- X.rootWindow d $ X.defaultScreen d a <- X.internAtom d "XMONAD_COMMAND" False X.allocaXEvent $ \e -> do XE.setEventType e X.clientMessage XE.setClientMessageEvent e rw a 32 (fromIntegral com) XE.currentTime X.sendEvent d rw False X.structureNotifyMask e X.sync d False