screenkell.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
import Graphics.X11
import Graphics.X11.Xlib.Types (Image(Image))
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Control.Applicative
import qualified Graphics.GD as GD
import qualified Data.ByteString.Char8 as BS
-- import qualified Data.ByteString.Lazy.Char8 as LB


data XImage = XImage { xiWidth :: CInt,
                       xiHeight :: CInt,
                       xiData :: Ptr CChar
                     }
instance Storable XImage where
    peek ptr = do w <- peek $ castPtr ptr
                  h <- peek $ castPtr ptr `plusPtr` sizeOf w
                  d <- peek $ castPtr ptr `plusPtr` (sizeOf w * 3)
                  return $ XImage w h d

{-class Rollable b where
    roll :: Ptr a -> b

instance Rollable (a -> IO a) where
    roll _ = return

instance (Rollable r) => Rollable (a -> r) where
    roll ptr f = do a <- peek $ castPtr ptr
                    let b = f a
                    let ptr' = ptr `plusPtr` sizeOf a
                    roll ptr' b-}


main :: IO ()
main = do
	dis <- openDisplay ""
	let win = defaultRootWindow dis
            vis = defaultVisual dis $ defaultScreen dis
            depth = defaultDepthOfScreen $ defaultScreenOfDisplay dis
            bpp = depth `div` 8
        putStrLn $ "depth: " ++ show depth

	(_,x,y,w,h,bw,d) <- getGeometry dis win
        img@(Image imgPtr) <- getImage dis win 0 0 w h 0xffff xyPixmap
        xi <- peek $ castPtr imgPtr :: IO XImage
        putStrLn $ "img: " ++ show (xiData xi)
        bs <- BS.pack <$> peekCStringLen (xiData xi, fromIntegral w * fromIntegral h * 4)
        -- sbs <- return $ BS.concat $ LB.toChunks bs
        GD.savePngFile "out.png" <$> GD.loadPngByteString bs
        destroyImage img

	putStrLn "Screen captured."
	closeDisplay dis