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 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 "png" []
return filepath