diff --git a/Graphics/Aosd.hs b/Graphics/Aosd.hs --- a/Graphics/Aosd.hs +++ b/Graphics/Aosd.hs @@ -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 diff --git a/Graphics/Aosd/Options.hs b/Graphics/Aosd/Options.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/Options.hs @@ -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 + diff --git a/Graphics/Aosd/Renderer.hs b/Graphics/Aosd/Renderer.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/Renderer.hs @@ -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 +-- } + diff --git a/Graphics/Aosd/Util.hs b/Graphics/Aosd/Util.hs --- a/Graphics/Aosd/Util.hs +++ b/Graphics/Aosd/Util.hs @@ -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 diff --git a/Graphics/Aosd/XUtil.hs b/Graphics/Aosd/XUtil.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/XUtil.hs @@ -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 + diff --git a/aosd.cabal b/aosd.cabal --- a/aosd.cabal +++ b/aosd.cabal @@ -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: . @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) { alignment = Just AlignCenter, colour = orange } + main = aosdFlash + \ defaultOpts + \ (textRenderer markup) { alignment = Just AlignCenter, colour = orange } \ (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