module XMonad.Util.WorkspaceScreenshot.Internal
(
initCapturing
, captureWorkspacesWhen
, captureWorkspacesWhenId
, defaultPredicate
, defaultHook
, CapturingLayout(..)
, horizontally
, vertically
) where
import Control.Applicative ((<$>))
import Control.Concurrent (threadDelay)
import Control.Monad (filterM, foldM_, (>=>))
import Data.Maybe (catMaybes)
import Data.String (fromString)
import Graphics.UI.Gtk (initGUI, Rectangle(..), drawableGetSize, drawWindowGetDefaultRootWindow)
import Graphics.UI.Gtk.Gdk.Pixbuf (Colorspace(ColorspaceRgb), Pixbuf, pixbufCopyArea, pixbufGetFromDrawable, pixbufGetHeight, pixbufGetWidth, pixbufNew, pixbufSave)
import XMonad hiding (Image, Rectangle)
import qualified XMonad.StackSet as S
initCapturing :: IO ()
initCapturing = initGUI >> return ()
captureWorkspacesWhen :: (WindowSpace -> X Bool) -> (FilePath -> IO ()) -> CapturingLayout -> X ()
captureWorkspacesWhen p hook = captureWorkspacesWhenId (workspaceIdToWindowSpace >=> p) hook
where
workspaceIdToWindowSpace i = gets $ head . filter (\w -> S.tag w == i) . S.workspaces . windowset
captureWorkspacesWhenId :: (WorkspaceId -> X Bool) -> (FilePath -> IO ()) -> CapturingLayout -> X ()
captureWorkspacesWhenId p hook mode = do
c <- gets $ S.currentTag . windowset
ps <- catMaybes <$> (mapM (\t -> windows (S.view t) >> captureScreen) =<< filterM p =<< asks (workspaces . config))
windows $ S.view c
xfork $ merge mode ps >>= hook
return ()
defaultPredicate :: a -> X Bool
defaultPredicate = const (return True)
defaultHook :: a -> IO ()
defaultHook = const (return ())
captureScreen :: X (Maybe Pixbuf)
captureScreen = liftIO $
do threadDelay 100000
rw <- drawWindowGetDefaultRootWindow
(w, h) <- drawableGetSize rw
pixbufGetFromDrawable rw (Rectangle 0 0 w h)
data CapturingLayout = CapturingLayout
{ dimensions :: [Pixbuf] -> IO (Int, Int)
, fill :: [Pixbuf] -> Pixbuf -> IO ()
}
horizontally :: CapturingLayout
horizontally = CapturingLayout
{ dimensions = \xs ->
do h <- maximum <$> mapM pixbufGetHeight xs
w <- sum <$> mapM pixbufGetWidth xs
return (h, w)
, fill = \ps p -> foldM_ (addTo p) 0 ps
}
where
addTo :: Pixbuf -> Int -> Pixbuf -> IO Int
addTo p a p' =
do w' <- pixbufGetWidth p'
h' <- pixbufGetHeight p'
pixbufCopyArea p' 0 0 w' h' p a 0
return (a + w')
vertically :: CapturingLayout
vertically = CapturingLayout
{ dimensions = \xs ->
do h <- sum <$> mapM pixbufGetHeight xs
w <- maximum <$> mapM pixbufGetWidth xs
return (h, w)
, fill = \ps p -> foldM_ (addTo p) 0 ps
}
where
addTo :: Pixbuf -> Int -> Pixbuf -> IO Int
addTo p a p' =
do w' <- pixbufGetWidth p'
h' <- pixbufGetHeight p'
pixbufCopyArea p' 0 0 w' h' p 0 a
return (a + h')
merge :: CapturingLayout -> [Pixbuf] -> IO FilePath
merge layout ps = do
(h, w) <- dimensions layout ps
p <- pixbufNew ColorspaceRgb False 8 w h
fill layout ps p
dir <- getXMonadDir
let filepath = (dir ++ "/screenshot.png")
pixbufSave p filepath (fromString "png") ([] :: [(String,String)])
return filepath