aosd 0.1.2 → 0.1.3

raw patch · 6 files changed

+399/−222 lines, 6 filesdep +monad-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monad-control

API changes (from Hackage documentation)

Files

• Graphics/Aosd.hs +154/−210
• Graphics/Aosd/Options.hs +74/−0
• Graphics/Aosd/Renderer.hs +82/−0
• Graphics/Aosd/Util.hs +43/−1
• Graphics/Aosd/XUtil.hs +24/−0
• aosd.cabal +22/−11

@@ -1,9 +1,9 @@-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE FlexibleContexts, Rank2Types, KindSignatures, NoMonomorphismRestriction, ExistentialQuantification, NamedFieldPuns, RecordWildCards #-} {-# OPTIONS -Wall #-} -- | For a higher-level API for textual OSDs using /Pango/, use "Graphics.Aosd.Pango". module Graphics.Aosd(     -- * Renderers-    AosdRenderer(..), GeneralRenderer(..), +    AosdRenderer(..), GeneralRenderer(..), --     -- ** Simple combinators --     HCatRenderer(..), VCatRenderer(..),     -- * Options@@ -12,191 +12,100 @@     aosdFlash,     FlashDurations(..), symDurations,     -- ** Low-level operations-    AosdPtr(..),aosdNew,reconfigure,+    AosdForeignPtr,aosdNew,aosdDestroy,reconfigure,     aosdRender, aosdShow, aosdHide, aosdLoopOnce, aosdLoopFor, +    -- * Diagnostics+    debugRenderer,+     -- * Reexports     module Graphics.Rendering.Cairo,     Rectangle(..),     CInt, CUInt -    -         ) where +import Control.Concurrent.MVar import Control.Exception-import Control.Monad.IO.Class import Control.Monad.Trans.Reader-import Foreign import Foreign.C+import Foreign.Ptr+import Foreign.StablePtr+import Foreign.Storable import Graphics.Aosd.AOSD_H+import Graphics.Aosd.Options+import Graphics.Aosd.Renderer import Graphics.Aosd.Util+import Graphics.Aosd.XUtil import Graphics.Rendering.Cairo-import Graphics.Rendering.Cairo.Internal(runRender)-import Data.Functor+import Graphics.Rendering.Cairo.Internal(runRender,Cairo) import Graphics.Rendering.Pango.Enums-import Graphics.X11.Xlib(openDisplay,closeDisplay,displayHeight,displayWidth,defaultScreen)+import System.IO.Unsafe -class AosdRenderer a where-    toGeneralRenderer :: a -> IO GeneralRenderer  -data XClassHint = XClassHint { resName, resClass :: String }-    deriving(Show) -data Transparency = None | Fake | Composite-    deriving(Show) -data Position = Min -- ^ Left/top-              | Center -              | Max -- ^ Right/bottom-    deriving(Show,Enum,Bounded) -data AosdOptions = AosdOptions {-    -- | 'Nothing' = use /libaosd/ default.-    classHint :: Maybe XClassHint,-    -- | 'Nothing' = use /libaosd/ default.-    transparency :: Maybe Transparency,-    xPos :: Position,-    yPos :: Position,-    -- | Positive values denote a rightwards respectively downwards offset (in pixels).-    offset :: (CInt,CInt),-    -- | 'Nothing' = use /libaosd/ default.-    hideUponMouseEvent :: Maybe Bool,-    -- | Mouse-click event handler.-    mouseEventCB :: Maybe (C'AosdMouseEvent -> IO ())-}--data GeneralRenderer = GeneralRenderer {-    grRender :: Render (),-    -- | Part of the surface that the renderer actually draws on (determines the window size).-    grInkExtent :: Rectangle,-    -- | Part of the surface whose...-    ---    -- * ... left edge is aligned to the left edge of the screen, if 'xPos' is 'Min'-    ---    -- * ... center is aligned to the center of the screen, if 'xPos' is 'Center'-    ---    -- * ... right edge is aligned to the right edge of the screen, if 'xPos' is 'Max'-    ---    -- (Likewise for the /y/ axis)-    grPositioningExtent :: Rectangle-}----- -- | Horizontal concatenation--- data HCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => HCat r1 r2--- --- --- -- | Vertical concatenation--- data VCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => VCat r1 r2---instance AosdRenderer GeneralRenderer where-    toGeneralRenderer = return---- instance AosdRenderer HCatRenderer where---     toGeneralRenderer (HCat r1 r2) = do---         gr1 <- toGeneralRenderer r1---         gr2 <- toGeneralRenderer r2---         return GeneralRenderer {---                     grWidth = ((+) `on` grWidth) gr1 gr2,---                     grHeight = (max `on` grHeight) gr1 gr2,---                     grRender = do---                         grRender gr1---                         translate (fromIntegral $ grWidth gr1) 0---                         grRender gr2---                }--- --- instance AosdRenderer VCatRenderer where---     toGeneralRenderer (VCat r1 r2) = do---         gr1 <- toGeneralRenderer r1---         gr2 <- toGeneralRenderer r2---         return GeneralRenderer {---                     grWidth = (max `on` grWidth) gr1 gr2,---                     grHeight = ((+) `on` grHeight) gr1 gr2,---                     grRender = do---                         grRender gr1---                         translate 0 (fromIntegral $ grHeight gr1)---                         grRender gr2---                }--toC'AosdRenderer :: Render () -> IO C'AosdRenderer-toC'AosdRenderer r = mk'AosdRenderer f-    where-        f cairo _ = runReaderT (runRender r) cairo---toAosdTransparency :: Transparency -> C'AosdTransparency-toAosdTransparency None = c'TRANSPARENCY_NONE-toAosdTransparency Fake = c'TRANSPARENCY_FAKE-toAosdTransparency Composite = c'TRANSPARENCY_COMPOSITE-- -- toAosdCoordinate :: Position -> C'AosdCoordinate -- toAosdCoordinate Min = c'COORDINATE_MINIMUM -- toAosdCoordinate Center = c'COORDINATE_CENTER -- toAosdCoordinate Max = c'COORDINATE_MAXIMUM  -withAosd :: (Ptr C'Aosd -> IO a) -> IO a-withAosd k = do-    a <- c'aosd_new -    finally (k a) (c'aosd_destroy a)+c'aosd_new_debug :: String -> IO (Ptr C'Aosd)+c'aosd_new_debug cxt = do+    p <- c'aosd_new+    putDebugMemory cxt ("c'aosd_new ==> "++show p)+    return p +c'aosd_destroy_debug :: String -> Ptr C'Aosd -> IO ()+c'aosd_destroy_debug cxt p = do+    putDebugMemory cxt ("c'aosd_destroy "++show p)+    c'aosd_destroy p +withAosd :: (Ptr C'Aosd -> IO a) -> IO a+withAosd = bracket (c'aosd_new_debug "withAosd") (c'aosd_destroy_debug "withAosd") -withConfiguredAosd :: AosdRenderer a => AosdOptions -> a -> (Ptr C'Aosd -> IO r) -> IO r-withConfiguredAosd opts x k = -    withAosd (\a -> do-        reconfigure0 opts x a -        k a-    )+type Render0 = Cairo -> IO ()  -data ScreenSize = ScreenSize { screenWidth, screenHeight :: Int }-    deriving(Show)  +withConfiguredAosd :: (AosdRenderer renderer) =>+                                                 AosdOptions -> renderer+                                              -> (Ptr C'Aosd -> IO a)+                                              -> IO a+withConfiguredAosd opts x k =+    withAosd (\a -> do+        z <- reconfigure0 opts x a+        k a `finally` freeAosdStructOwnedData "withConfiguredAosd" z +    ) -getScreenSize :: IO ScreenSize-getScreenSize = do-        display <- openDisplay "" -        let go = do-                -- Work around unsafe FFI declarations in the X11 bindings...-                screen <- evaluate $ defaultScreen display-                screenWidth <- evaluate . fromIntegral $ displayWidth display screen-                screenHeight <- evaluate . fromIntegral $ displayHeight display screen -                return ScreenSize{..} -        go `finally` closeDisplay display--reconfigure0 :: AosdRenderer a => AosdOptions -> a -> Ptr C'Aosd -> IO ()-reconfigure0 AosdOptions{..} renderer a = do-        GeneralRenderer{..} <- toGeneralRenderer renderer -        maybeDo (setClassHint a) classHint-        -        maybeDo (c'aosd_set_transparency a . toAosdTransparency) transparency+reconfigure0 :: (AosdRenderer renderer) => AosdOptions -> renderer -> Ptr C'Aosd -> IO AosdStructOwnedData+reconfigure0 AosdOptions{..} renderer ptr = do+        GeneralRenderer{..} <- toGeneralRenderer renderer          ScreenSize{..} <- getScreenSize  -        let -- l=Left, t=Top, w=Width, h=Height +        let -- l=Left, t=Top, w=Width, h=Height             Rectangle li ti wi hi = grInkExtent             Rectangle lp tp wp hp = grPositioningExtent -{- -(These comments only look at the x dimension; the other is analogous) +{-+(These comments only look at the x dimension; the other is analogous)  Consider the mapping "screenx" from grRender x coordinates to screen x coordinates  Since we translate grRender by -(li,ti), we have: -        screenx x = windowLeft + x - li +        screenx x = windowLeft + x - li -If xPos is Min, we want: +If xPos is Min, we want:          screenx lp = 0         <=>@@ -210,7 +119,7 @@         <=>         windowLeft + (lp + wp/2) - li = screenWidth/2         <=>-        windowLeft = li - lp + (screenWidth - wp)/2 +        windowLeft = li - lp + (screenWidth - wp)/2  If xPos is Max, we want: @@ -221,13 +130,12 @@         windowLeft = li - lp + screenWidth - wp  -}-            calculateOffsetAdjustment pos min_ink min_positioning size_positioning size_screen  = fromIntegral $ +            calculateOffsetAdjustment pos min_ink min_positioning size_positioning size_screen  = fromIntegral $                         case pos of                               Min -> min_ink - min_positioning                               Center -> min_ink - min_positioning + div (size_screen - size_positioning) 2-                              Max -> min_ink - min_positioning + size_screen - size_positioning +                              Max -> min_ink - min_positioning + size_screen - size_positioning -                                    windowLeft = calculateOffsetAdjustment xPos li lp wp screenWidth  + fst offset             windowTop  = calculateOffsetAdjustment yPos ti tp hp screenHeight + snd offset@@ -241,18 +149,41 @@   -        c'aosd_set_geometry a windowLeft windowTop windowWidth windowHeight-             -        rendererPtr <- toC'AosdRenderer finalRenderer-        c'aosd_set_renderer a rendererPtr nullPtr  -        maybeDo (setHideUponMouseEvent a) hideUponMouseEvent -        maybeDo (setMouseEventCB a) mouseEventCB+        maybeDo (setClassHint ptr) classHint+        maybeDo (setHideUponMouseEvent ptr) hideUponMouseEvent+        maybeDo (setMouseEventCB ptr) mouseEventCB +        rendererPtr <- newStablePtrDebug "reconfigure0" "renderer" (runReaderT . runRender $ finalRenderer)+++        maybeDo (c'aosd_set_transparency ptr . toAosdTransparency) transparency+        c'aosd_set_geometry ptr windowLeft windowTop windowWidth windowHeight+        c'aosd_set_renderer ptr theC'AosdRenderer (castCairoIOStablePtrToPtr rendererPtr)++        return (AosdStructOwnedData rendererPtr)++++castCairoIOStablePtrToPtr :: StablePtr Render0 -> Ptr ()+castCairoIOStablePtrToPtr = castStablePtrToPtr++-- | Excepts its second argument to be a (StablePtr (Cairo -> IO ())).+theAosdRenderer :: Cairo -> Ptr () -> IO ()+theAosdRenderer cairo p = do+    render <- Foreign.StablePtr.deRefStablePtr (Foreign.StablePtr.castPtrToStablePtr p) :: IO Render0+    render cairo++-- | A 'FunPtr' to 'theAosdRenderer'.+{-# NOINLINE theC'AosdRenderer #-}+theC'AosdRenderer :: C'AosdRenderer+theC'AosdRenderer = unsafePerformIO (mk'AosdRenderer theAosdRenderer)++ setClassHint :: Ptr C'Aosd -> XClassHint -> IO ()-setClassHint a XClassHint{ resName, resClass } = +setClassHint a XClassHint{ resName, resClass } =     withCString resName (\resName' ->         withCString resClass (\resClass' ->             c'aosd_set_names a resName' resClass'))@@ -263,86 +194,99 @@ setMouseEventCB :: Ptr C'Aosd -> (C'AosdMouseEvent -> IO ()) -> IO () setMouseEventCB a f = do     fptr <- mk'AosdMouseEventCb f'-    c'aosd_set_mouse_event_cb a fptr nullPtr+    c'aosd_set_mouse_event_cb a fptr Foreign.Ptr.nullPtr   where-    f' :: Ptr C'AosdMouseEvent -> Ptr () -> IO () -    f' p _ = do -        mouseEvent <- peek p +    f' :: Ptr C'AosdMouseEvent -> Ptr () -> IO ()+    f' p _ = do+        mouseEvent <- peek p         f mouseEvent --- | Non-'Nothing' defaults:------ *       transparency = Just Composite,------ *       xPos = Center, ------ *       yPos = Center,--- --- *       offset = (0,0),------ *       hideUponMouseEvent = Just True-defaultOpts :: AosdOptions-defaultOpts =-    AosdOptions { -        classHint = Nothing,-        transparency = Just Composite,-        xPos = Center, -        yPos = Center,-        offset = (0,0),-        hideUponMouseEvent = Just True,-        mouseEventCB = Nothing-    } -data FlashDurations = FlashDurations {-    inMillis :: CUInt -- ^ Fade-in time in milliseconds -  , fullMillis :: CUInt -- ^ Full display time in milliseconds-  , outMillis :: CUInt -- ^ Fade-out time in milliseconds-}-    deriving(Show)+-- | Main high-level displayer. Blocks.+aosdFlash :: (AosdRenderer a) => AosdOptions -> a -> FlashDurations -> IO ()+aosdFlash opts renderer durations = withConfiguredAosd opts renderer (aosdFlash' durations) --- | Construct a 'FlashDurations' with equal 'inMillis' and 'outMillis'.-symDurations :: -        CUInt -- ^ 'inMillis' and 'outMillis'. -     -> CUInt -- ^ 'fullMillis'.-     -> FlashDurations-symDurations fadeMillis fullMillis = FlashDurations fadeMillis fullMillis fadeMillis --- | Main high-level displayer. Blocks. -aosdFlash :: AosdRenderer a => AosdOptions -> a -> FlashDurations -> IO ()-aosdFlash opts renderer FlashDurations{..} = -    withConfiguredAosd opts renderer (\p -> c'aosd_flash p inMillis fullMillis outMillis)+aosdFlash' :: FlashDurations -> Ptr C'Aosd -> IO ()+aosdFlash' FlashDurations{..} a = (c'aosd_flash a inMillis fullMillis outMillis) -                               +data AosdForeignPtr = AosdForeignPtr { unAosdPtr :: !(Ptr C'Aosd)+                                        -- This has the sole purpose of keeping the AosdStructOwnedData alive+                                     , aosdStructOwnedDataVar :: !(MVar AosdStructOwnedData)+                                     } +aosdNew :: (AosdRenderer renderer) => AosdOptions -> renderer -> IO AosdForeignPtr+aosdNew opts r = do+    unAosdPtr <- c'aosd_new_debug "aosdNew"+    z <- reconfigure0 opts r unAosdPtr+    aosdStructOwnedDataVar <- newMVar z +    {-+        The ForeignPtr C'Aosd should keep the reference to its AosdStructOwnedData alive.+        Otherwise, something like this could access already freed memory: -newtype AosdPtr = AosdPtr { unAosdPtr :: ForeignPtr C'Aosd }+            do+                thunk <- do +                        aosd <- aosdNew defaultOpts debugRenderer  +                        return (aosdShow aosd)  --- | Create an /Aosd/ object managed by the garbage collector.-aosdNew :: AosdRenderer a => AosdOptions -> a -> IO AosdPtr-aosdNew opts r = do-    p <- c'aosd_new-    reconfigure0 opts r p-    AosdPtr <$> Foreign.newForeignPtr p'aosd_destroy p+                -- @thunk@ only references @unAosdPtr aosd@, not @aosdStructOwnedDataVar aosd@!+                -- (The reference from the Aosd struct to the StablePtrs is only on the C side)+                --+                -- ... the @AosdStructOwnedData@ produced in aosdNew is finalized (the StablePtrs in it are freed) ... +                thunk -- Causes the C side to pass a dead StablePtr back to @theC'AosdRenderer@! -reconfigure :: AosdRenderer a => AosdOptions -> a -> AosdPtr -> IO ()-reconfigure opts r = (`withForeignPtr` reconfigure0 opts r) . unAosdPtr -aosdRender :: AosdPtr -> IO ()-aosdRender = (`withForeignPtr` c'aosd_render) . unAosdPtr+    -} -aosdShow :: AosdPtr -> IO ()-aosdShow = (`withForeignPtr` c'aosd_show) . unAosdPtr+    return AosdForeignPtr {unAosdPtr,aosdStructOwnedDataVar} -aosdHide :: AosdPtr -> IO ()-aosdHide = (`withForeignPtr` c'aosd_hide) . unAosdPtr -aosdLoopOnce :: AosdPtr -> IO ()-aosdLoopOnce = (`withForeignPtr` c'aosd_loop_once) . unAosdPtr -aosdLoopFor :: AosdPtr -            -> CUInt -- ^ Time in milliseconds.-            -> IO ()-aosdLoopFor (AosdPtr fp) millis = (fp `withForeignPtr` (`c'aosd_loop_for` millis))  +reconfigure :: (AosdRenderer renderer) =>+        AosdOptions+     -> renderer+     -> AosdForeignPtr+     -> IO ()++reconfigure opts r (AosdForeignPtr fp var) = modifyMVar_ var+    (\zOld -> do+        zNew <- reconfigure0 opts r fp+        freeAosdStructOwnedData "reconfigure" zOld+        return zNew)+++aosdRender :: AosdForeignPtr -> IO ()+aosdRender = (c'aosd_render) . unAosdPtr++aosdShow :: AosdForeignPtr -> IO ()+aosdShow = (c'aosd_show) . unAosdPtr++aosdHide :: AosdForeignPtr -> IO ()+aosdHide = (c'aosd_hide) . unAosdPtr++aosdLoopOnce :: AosdForeignPtr -> IO ()+aosdLoopOnce = (c'aosd_loop_once) . unAosdPtr++aosdLoopFor ::+        AosdForeignPtr+     -> CUInt -- ^ Time in milliseconds.+     -> IO ()+aosdLoopFor (AosdForeignPtr fp _) millis = c'aosd_loop_for fp millis+++data AosdStructOwnedData = AosdStructOwnedData !(StablePtr (Cairo -> IO ()))++++freeAosdStructOwnedData :: String -> AosdStructOwnedData -> IO ()+freeAosdStructOwnedData cxt (AosdStructOwnedData sp_r) = do+    freeStablePtrDebug cxt "renderer" sp_r++aosdDestroy :: AosdForeignPtr -> IO ()+aosdDestroy (AosdForeignPtr p var) = do+    c'aosd_destroy_debug "aosdDestroy" p+    z <- readMVar var+    freeAosdStructOwnedData "aosdDestroy" z

@@ -0,0 +1,74 @@+{-# OPTIONS -Wall #-}+module Graphics.Aosd.Options where++import Graphics.Aosd.AOSD_H+import Foreign.C.Types++data XClassHint = XClassHint { resName, resClass :: String }+    deriving(Show)++data Transparency = None | Fake | Composite+    deriving(Show)++data Position = Min -- ^ Left/top+              | Center+              | Max -- ^ Right/bottom+    deriving(Show,Enum,Bounded)++data AosdOptions = AosdOptions {+    -- | 'Nothing' = use /libaosd/ default.+    classHint :: Maybe XClassHint,+    -- | 'Nothing' = use /libaosd/ default.+    transparency :: Maybe Transparency,+    xPos :: Position,+    yPos :: Position,+    -- | Positive values denote a rightwards respectively downwards offset (in pixels).+    offset :: (CInt,CInt),+    -- | 'Nothing' = use /libaosd/ default.+    hideUponMouseEvent :: Maybe Bool,+    -- | Mouse-click event handler.+    mouseEventCB :: Maybe (C'AosdMouseEvent -> IO ())+}++toAosdTransparency :: Transparency -> C'AosdTransparency+toAosdTransparency None = c'TRANSPARENCY_NONE+toAosdTransparency Fake = c'TRANSPARENCY_FAKE+toAosdTransparency Composite = c'TRANSPARENCY_COMPOSITE++-- | Non-'Nothing' defaults:+--+-- *       transparency = Just Composite,+--+-- *       xPos = Center,+--+-- *       yPos = Center,+--+-- *       offset = (0,0),+--+-- *       hideUponMouseEvent = Just True+defaultOpts :: AosdOptions+defaultOpts =+    AosdOptions {+        classHint = Nothing,+        transparency = Just Composite,+        xPos = Center,+        yPos = Center,+        offset = (0,0),+        hideUponMouseEvent = Just True,+        mouseEventCB = Nothing+    }++data FlashDurations = FlashDurations {+    inMillis :: CUInt -- ^ Fade-in time in milliseconds+  , fullMillis :: CUInt -- ^ Full display time in milliseconds+  , outMillis :: CUInt -- ^ Fade-out time in milliseconds+}+    deriving(Show)++-- | Construct a 'FlashDurations' with equal 'inMillis' and 'outMillis'.+symDurations ::+        CUInt -- ^ 'inMillis' and 'outMillis'.+     -> CUInt -- ^ 'fullMillis'.+     -> FlashDurations+symDurations fadeMillis fullMillis_ = FlashDurations fadeMillis fullMillis_ fadeMillis+

@@ -0,0 +1,82 @@+{-# OPTIONS -Wall #-}+module Graphics.Aosd.Renderer where+import Graphics.Rendering.Cairo+import Graphics.Rendering.Pango.Enums+import Graphics.Aosd.Util+++class AosdRenderer a where+    toGeneralRenderer :: a -> IO GeneralRenderer++data GeneralRenderer = GeneralRenderer {+    grRender :: Render (),+    -- | Part of the surface that the renderer actually draws on (determines the window size).+    grInkExtent :: Rectangle,+    -- | Part of the surface whose...+    --+    -- * ... left edge is aligned to the left edge of the screen, if 'xPos' is 'Min'+    --+    -- * ... center is aligned to the center of the screen, if 'xPos' is 'Center'+    --+    -- * ... right edge is aligned to the right edge of the screen, if 'xPos' is 'Max'+    --+    -- (Likewise for the /y/ axis)+    grPositioningExtent :: Rectangle+}+ +instance AosdRenderer GeneralRenderer where+    toGeneralRenderer = return++debugRenderer :: GeneralRenderer+debugRenderer =+    GeneralRenderer {+        grInkExtent = rect,+        grPositioningExtent = rect,+        grRender = do+            liftIO (putStdErr "debugRenderer invoked")+            setLineWidth lw+            setSourceRGB  0 1 0+            arc 0 0 (r - lw) 0 (2*pi)+            stroke+    }+        where+            rect = Rectangle (-r) (-r) (2*r) (2*r)+            r :: Num a => a+            r = 100+            lw = 5++-- -- | Horizontal concatenation+-- data HCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => HCat r1 r2+--+--+-- -- | Vertical concatenation+-- data VCatRenderer = forall r1 r2. (AosdRenderer r1, AosdRenderer r2) => VCat r1 r2++++-- instance AosdRenderer HCatRenderer where+--     toGeneralRenderer (HCat r1 r2) = do+--         gr1 <- toGeneralRenderer r1+--         gr2 <- toGeneralRenderer r2+--         return GeneralRenderer {+--                     grWidth = ((+) `on` grWidth) gr1 gr2,+--                     grHeight = (max `on` grHeight) gr1 gr2,+--                     grRender = do+--                         grRender gr1+--                         translate (fromIntegral $ grWidth gr1) 0+--                         grRender gr2+--                }+--+-- instance AosdRenderer VCatRenderer where+--     toGeneralRenderer (VCat r1 r2) = do+--         gr1 <- toGeneralRenderer r1+--         gr2 <- toGeneralRenderer r2+--         return GeneralRenderer {+--                     grWidth = (max `on` grWidth) gr1 gr2,+--                     grHeight = ((+) `on` grHeight) gr1 gr2,+--                     grRender = do+--                         grRender gr1+--                         translate 0 (fromIntegral $ grHeight gr1)+--                         grRender gr2+--                }+

@@ -1,9 +1,15 @@-{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction #-}+{-# LANGUAGE CPP, ViewPatterns, NoMonomorphismRestriction #-} module Graphics.Aosd.Util where import Graphics.Rendering.Pango.Enums import Control.Arrow import Data.Colour.SRGB import Graphics.Rendering.Cairo+import Foreign.StablePtr+import System.IO+import Control.Monad+import Foreign.Concurrent+import Foreign.Ptr+import Foreign.ForeignPtr(ForeignPtr)  maybeDo :: Monad m => (a -> m ()) -> Maybe a -> m () maybeDo f = maybe (return ()) f@@ -63,3 +69,39 @@ setSourceColour :: Colour Double -> Double -> Render () setSourceColour (toSRGB -> RGB r g b) a = setSourceRGBA r g b a +debugMemory :: Bool+putDebugMemory :: String -> String -> IO ()+#ifdef DEBUG_MEMORY+debugMemory = True+putDebugMemory cxt msg = putStdErr (cxt ++ ": "++replicate (30 - length cxt) ' ' ++ msg)+#else+debugMemory = False+putDebugMemory _ _ = return ()+#endif++showStablePtr ::  StablePtr a -> String+showStablePtr = show . castStablePtrToPtr++putStdErr :: String -> IO ()+putStdErr = hPutStrLn stderr+++newStablePtrDebug :: String -> String -> a -> IO (StablePtr a)+newStablePtrDebug cxt descr a = do+    sp <- newStablePtr a+    putDebugMemory cxt ("Created "++descr++" StablePtr: "++showStablePtr sp) +    return sp++freeStablePtrDebug :: String -> String -> StablePtr a -> IO ()+freeStablePtrDebug cxt descr sp = do+    putDebugMemory cxt ("Freeing "++descr++" StablePtr: "++showStablePtr sp) +    freeStablePtr sp++newForeignPtrDebug :: String -> String -> IO () -> Ptr a -> IO (ForeignPtr a)+newForeignPtrDebug cxt descr finalizer p = do+    fp <- newForeignPtr p +                (do+                    putDebugMemory "ForeignPtr finalizer" ("Finalizing "++descr++" ForeignPtr made in "++cxt)   +                    finalizer)+    putDebugMemory cxt ("Created "++descr++" ForeignPtr: "++show fp)+    return fp

@@ -0,0 +1,24 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+module Graphics.Aosd.XUtil where+import Graphics.X11.Xlib.Display+import Control.Exception++data ScreenSize = ScreenSize { screenWidth, screenHeight :: Int }+    deriving(Show)+++getScreenSize :: IO ScreenSize+getScreenSize = do+        display <- openDisplay ""++        let go = do+                -- Work around unsafe FFI declarations in the X11 bindings...+                screen <- evaluate $ defaultScreen display+                screenWidth <- evaluate . fromIntegral $ displayWidth display screen+                screenHeight <- evaluate . fromIntegral $ displayHeight display screen++                return ScreenSize{..}++        go `finally` closeDisplay display+

@@ -2,9 +2,9 @@ -- see -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. Name:                aosd-Version:             0.1.2+Version:             0.1.3 Synopsis:            Bindings to libaosd, a library for Cairo-based on-screen displays-Description:         +Description:  <http://www.atheme.org/project/libaosd>  .  @An advanced on screen display (OSD) library, which uses Cairo to create high quality rendered graphics to be overlaid on top of the screen.@@@ -21,9 +21,9 @@  .  markup = pSized 50 (pUnlines [pItalic \"AOSD\",\"Example\"])  .- main = aosdFlash - \           defaultOpts - \           (textRenderer markup) &#123; alignment = Just AlignCenter, colour = orange &#125; + main = aosdFlash+ \           defaultOpts+ \           (textRenderer markup) &#123; alignment = Just AlignCenter, colour = orange &#125;  \           (symDurations 3000 3000)  @  .@@ -33,7 +33,7 @@ License-file:        LICENSE Author:              Daniel Schüssler Maintainer:          anotheraddress@gmx.de--- Copyright:           +-- Copyright: Category:            Graphics Build-type:          Simple Extra-source-files:  test/test.hs@@ -41,22 +41,33 @@  source-repository head   type:     hg-  location: https://dschuessler@bitbucket.org/dschuessler/haskell-aosd +  location: https://dschuessler@bitbucket.org/dschuessler/haskell-aosd +Flag DebugMemory+    Default: False+    Manual: True+ Library   Default-Extensions: ForeignFunctionInterface-  Exposed-modules: -    Graphics.Aosd.AOSD_H +  Exposed-modules:+    Graphics.Aosd.AOSD_H     Graphics.Aosd     Graphics.Aosd.Pango-  Other-modules:       +  Other-modules:+    Graphics.Aosd.Options+    Graphics.Aosd.Renderer     Graphics.Aosd.Util+    Graphics.Aosd.XUtil  -  Build-depends:       colour, transformers, X11, base >= 4 && < 5, bindings-DSL >= 1.0.11, cairo >= 0.12, pango >= 0.12 +  Build-depends:       monad-control, colour, transformers, X11, base >= 4 && < 5, bindings-DSL >= 1.0.11, cairo >= 0.12, pango >= 0.12   Build-tools:         hsc2hs   Pkgconfig-depends:   libaosd   Default-language: Haskell2010++  if(flag(DebugMemory))+    Cpp-options: -DDEBUG_MEMORY+  Test-Suite test-aosd     type:       exitcode-stdio-1.0