diff --git a/Graphics/Aosd.hs b/Graphics/Aosd.hs --- a/Graphics/Aosd.hs +++ b/Graphics/Aosd.hs @@ -8,11 +8,13 @@ -- HCatRenderer(..), VCatRenderer(..), -- * Options AosdOptions(..), Transparency(..), Position(..), XClassHint(..), defaultOpts, + -- * Construction/destruction + AosdPtr,aosdNew,aosdDestroy,withAosd, -- * Displaying aosdFlash, FlashDurations(..), symDurations, -- ** Low-level operations - AosdForeignPtr,aosdNew,aosdDestroy,reconfigure, + reconfigure, aosdRender, aosdShow, aosdHide, aosdLoopOnce, aosdLoopFor, -- * Diagnostics @@ -26,7 +28,6 @@ ) where import Control.Concurrent.MVar -import Control.Exception import Control.Monad.Trans.Reader import Foreign.C import Foreign.Ptr @@ -36,11 +37,15 @@ import Graphics.Aosd.Options import Graphics.Aosd.Renderer import Graphics.Aosd.Util +import Graphics.Aosd.CallbackUtil import Graphics.Aosd.XUtil import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo.Internal(runRender,Cairo) import Graphics.Rendering.Pango.Enums import System.IO.Unsafe +import Graphics.X11.Xlib(Display,openDisplay,closeDisplay) +import Control.Exception +import Data.Maybe @@ -64,39 +69,12 @@ 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") - -type Render0 = Cairo -> IO () - - - - -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 - ) - +type MouseEventHandler = AosdPtr -> C'AosdMouseEvent -> IO () -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 - Rectangle li ti wi hi = grInkExtent - Rectangle lp tp wp hp = grPositioningExtent +{- Position calculation comments: -{- (These comments only look at the x dimension; the other is analogous) Consider the mapping "screenx" from grRender x coordinates to screen x coordinates @@ -130,6 +108,21 @@ windowLeft = li - lp + screenWidth - wp -} + + +-- | Must *NOT* access the aosdStructOwnedDataVar of the AosdPtr argument (-> deadlock). +reconfigure0 :: (AosdRenderer renderer) => AosdOptions -> renderer -> AosdPtr -> IO AosdStructOwnedData +reconfigure0 AosdOptions{..} renderer aosd@AosdPtr {unAosdPtr=ptr, display} = + do + GeneralRenderer{..} <- toGeneralRenderer renderer + + ScreenSize{..} <- getScreenSize display + + + let -- l=Left, t=Top, w=Width, h=Height + Rectangle li ti wi hi = grInkExtent + Rectangle lp tp wp hp = grPositioningExtent + calculateOffsetAdjustment pos min_ink min_positioning size_positioning size_screen = fromIntegral $ case pos of Min -> min_ink - min_positioning @@ -147,41 +140,37 @@ translate (fi . negate $ li) (fi . negate $ ti) grRender - - - - - maybeDo (setClassHint ptr) classHint maybeDo (setHideUponMouseEvent ptr) hideUponMouseEvent - maybeDo (setMouseEventCB ptr) mouseEventCB + + rendererPtr <- setRenderer ptr finalRenderer + handlerPtr <- traverseMaybe (setMouseEventCB aosd) 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) + return (AosdStructOwnedData rendererPtr handlerPtr) +-- | Does *NOT* free the old handler +setRenderer :: Ptr C'Aosd -> Render () -> IO (StablePtr (Cairo -> IO ())) +setRenderer ptr renderer = tunnelCallback theC'AosdRenderer (c'aosd_set_renderer ptr) f + where + f = runReaderT . runRender $ renderer +{-# NOINLINE theC'AosdRenderer #-} +theC'AosdRenderer :: UniversalCallback Cairo +theC'AosdRenderer = unsafePerformIO $ mkUniversalCallback mk'AosdRenderer -castCairoIOStablePtrToPtr :: StablePtr Render0 -> Ptr () -castCairoIOStablePtrToPtr = castStablePtrToPtr +{-# NOINLINE theC'AosdMouseEventCb #-} +theC'AosdMouseEventCb :: UniversalCallback (Ptr C'AosdMouseEvent) +theC'AosdMouseEventCb = unsafePerformIO $ mkUniversalCallback mk'AosdMouseEventCb --- | 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 } = withCString resName (\resName' -> @@ -191,56 +180,43 @@ setHideUponMouseEvent :: Ptr C'Aosd -> Bool -> IO () setHideUponMouseEvent a b = c'aosd_set_hide_upon_mouse_event a (if b then 1 else 0) -setMouseEventCB :: Ptr C'Aosd -> (C'AosdMouseEvent -> IO ()) -> IO () -setMouseEventCB a f = do - fptr <- mk'AosdMouseEventCb f' - 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 mouseEvent +-- | Does *NOT* free the old handler. +-- Must *NOT* access the aosdStructOwnedDataVar of the AosdPtr argument (-> deadlock). +setMouseEventCB :: AosdPtr -> MouseEventHandler -> IO (StablePtr (Ptr C'AosdMouseEvent -> IO ())) +setMouseEventCB aosd@AosdPtr {unAosdPtr=ptr} handler = tunnelCallback theC'AosdMouseEventCb (c'aosd_set_mouse_event_cb ptr) f + where + f eventp = do + event <- peek eventp + handler aosd event -- | Main high-level displayer. Blocks. -aosdFlash :: (AosdRenderer a) => AosdOptions -> a -> FlashDurations -> IO () -aosdFlash opts renderer durations = withConfiguredAosd opts renderer (aosdFlash' durations) - - -aosdFlash' :: FlashDurations -> Ptr C'Aosd -> IO () -aosdFlash' FlashDurations{..} a = (c'aosd_flash a inMillis fullMillis outMillis) +aosdFlash :: AosdPtr -> FlashDurations -> IO () +aosdFlash a FlashDurations{..} = wrapAosd (\p -> c'aosd_flash p inMillis fullMillis outMillis) a -data AosdForeignPtr = AosdForeignPtr { unAosdPtr :: !(Ptr C'Aosd) - -- This has the sole purpose of keeping the AosdStructOwnedData alive - , aosdStructOwnedDataVar :: !(MVar AosdStructOwnedData) +data AosdPtr = AosdPtr { unAosdPtr :: !(Ptr C'Aosd) + -- We only keep this around for deallocating + , aosdStructOwnedDataVar :: !(MVar (Maybe AosdStructOwnedData)) + , display :: Display } -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: - - do - thunk <- do - aosd <- aosdNew defaultOpts debugRenderer - return (aosdShow aosd) - - -- @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) ... +aosdNew0 :: IO AosdPtr +aosdNew0 = do + display <- openDisplay "" + unAosdPtr <- c'aosd_new_debug "aosdNew" + aosdStructOwnedDataVar <- newMVar Nothing - thunk -- Causes the C side to pass a dead StablePtr back to @theC'AosdRenderer@! + return AosdPtr {unAosdPtr,aosdStructOwnedDataVar,display} - -} +aosdNew :: (AosdRenderer renderer) => AosdOptions -> renderer -> IO AosdPtr +aosdNew opts r = do + aosd <- aosdNew0 + z <- reconfigure0 opts r aosd + modifyMVar_ (aosdStructOwnedDataVar aosd) (\x -> assert (isNothing x) $ return (Just z)) - return AosdForeignPtr {unAosdPtr,aosdStructOwnedDataVar} + return aosd @@ -248,45 +224,58 @@ reconfigure :: (AosdRenderer renderer) => AosdOptions -> renderer - -> AosdForeignPtr + -> AosdPtr -> IO () -reconfigure opts r (AosdForeignPtr fp var) = modifyMVar_ var +reconfigure opts r aosd@AosdPtr {aosdStructOwnedDataVar} = modifyMVar_ aosdStructOwnedDataVar (\zOld -> do - zNew <- reconfigure0 opts r fp - freeAosdStructOwnedData "reconfigure" zOld - return zNew) + zNew <- reconfigure0 opts r aosd + maybeDo (freeAosdStructOwnedData "reconfigure") zOld + return (Just zNew)) +wrapAosd :: (Ptr C'Aosd -> c) -> AosdPtr -> c +wrapAosd f = f . unAosdPtr -aosdRender :: AosdForeignPtr -> IO () -aosdRender = (c'aosd_render) . unAosdPtr +aosdRender :: AosdPtr -> IO () +aosdRender = wrapAosd c'aosd_render -aosdShow :: AosdForeignPtr -> IO () -aosdShow = (c'aosd_show) . unAosdPtr +aosdShow :: AosdPtr -> IO () +aosdShow = wrapAosd c'aosd_show -aosdHide :: AosdForeignPtr -> IO () -aosdHide = (c'aosd_hide) . unAosdPtr +aosdHide :: AosdPtr -> IO () +aosdHide = wrapAosd c'aosd_hide -aosdLoopOnce :: AosdForeignPtr -> IO () -aosdLoopOnce = (c'aosd_loop_once) . unAosdPtr +aosdLoopOnce :: AosdPtr -> IO () +aosdLoopOnce = wrapAosd c'aosd_loop_once aosdLoopFor :: - AosdForeignPtr + AosdPtr -> CUInt -- ^ Time in milliseconds. -> IO () -aosdLoopFor (AosdForeignPtr fp _) millis = c'aosd_loop_for fp millis +aosdLoopFor a millis = wrapAosd (flip c'aosd_loop_for millis) a -data AosdStructOwnedData = AosdStructOwnedData !(StablePtr (Cairo -> IO ())) +data AosdStructOwnedData = + AosdStructOwnedData + !(StablePtr (Cairo -> IO ())) + !(Maybe (StablePtr (Ptr C'AosdMouseEvent -> IO()))) freeAosdStructOwnedData :: String -> AosdStructOwnedData -> IO () -freeAosdStructOwnedData cxt (AosdStructOwnedData sp_r) = do +freeAosdStructOwnedData cxt (AosdStructOwnedData sp_r sp_h) = do freeStablePtrDebug cxt "renderer" sp_r + maybeDo (freeStablePtrDebug cxt "mouse event handler") sp_h -aosdDestroy :: AosdForeignPtr -> IO () -aosdDestroy (AosdForeignPtr p var) = do - c'aosd_destroy_debug "aosdDestroy" p - z <- readMVar var - freeAosdStructOwnedData "aosdDestroy" z +aosdDestroy :: AosdPtr -> IO () +aosdDestroy AosdPtr {unAosdPtr, aosdStructOwnedDataVar, display} = + modifyMVar_ aosdStructOwnedDataVar $ \z -> do + c'aosd_destroy_debug "aosdDestroy" unAosdPtr + maybeDo (freeAosdStructOwnedData "aosdDestroy") z + closeDisplay display + return Nothing + + +-- | 'aosdNew'/'aosdDestroy' bracket. Leaking the 'AosdPtr' out of the third argument leads to undefined behaviour. +withAosd :: AosdRenderer renderer => AosdOptions -> renderer -> (AosdPtr -> IO c) -> IO c +withAosd opts ren = bracket (aosdNew opts ren) aosdDestroy diff --git a/Graphics/Aosd.hs-boot b/Graphics/Aosd.hs-boot new file mode 100644 --- /dev/null +++ b/Graphics/Aosd.hs-boot @@ -0,0 +1,2 @@ +module Graphics.Aosd where +data AosdPtr diff --git a/Graphics/Aosd/CallbackUtil.hs b/Graphics/Aosd/CallbackUtil.hs new file mode 100644 --- /dev/null +++ b/Graphics/Aosd/CallbackUtil.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wall #-} +module Graphics.Aosd.CallbackUtil(UserData,Callback,UniversalCallback,mkUniversalCallback,tunnelCallback) where + +import Foreign +import Graphics.Aosd.Util + + +type UserData = Ptr () + + +type Callback a = a -> UserData -> IO () + +-- | A callback which assumes that its 'UserData' argument is a @'StablePtr' (a -> IO ())@ and +-- delegates the @a@ to that @a -> IO ()@. +newtype UniversalCallback a = UniversalCallback (FunPtr (Callback a)) + +mkUniversalCallback :: forall a. + (Callback a -> IO (FunPtr (Callback a))) + -- ^ Should be something obtained from a @foreign import ccall \"wrapper\" ...@ declaration + -> IO (UniversalCallback a) +mkUniversalCallback foreignImportWrapper = + UniversalCallback `fmap` foreignImportWrapper universalCallback + +universalCallback :: a -> Ptr () -> IO () +universalCallback a userData = do + handler <- deRefStablePtr (castPtrToStablePtr userData) :: IO (a -> IO ()) + handler a + +tunnelCallback :: + UniversalCallback a + -> (FunPtr (Callback a) -> UserData -> IO ()) -- ^ The C-imported callback setter function + -> (a -> IO ()) -- ^ The haskell function you want to be called back + -> IO (StablePtr (a -> IO ())) -- ^ Returns a StablePtr which needs to be freed once the callback is no longer used + +tunnelCallback (UniversalCallback u) setCallback haskellCallback = do + sp <- newStablePtrDebug "tunnelCallback" "callback" haskellCallback + setCallback u (castStablePtrToPtr sp) + return sp + diff --git a/Graphics/Aosd/Options.hs b/Graphics/Aosd/Options.hs --- a/Graphics/Aosd/Options.hs +++ b/Graphics/Aosd/Options.hs @@ -3,6 +3,7 @@ import Graphics.Aosd.AOSD_H import Foreign.C.Types +import {-# SOURCE #-} Graphics.Aosd data XClassHint = XClassHint { resName, resClass :: String } deriving(Show) @@ -27,7 +28,7 @@ -- | 'Nothing' = use /libaosd/ default. hideUponMouseEvent :: Maybe Bool, -- | Mouse-click event handler. - mouseEventCB :: Maybe (C'AosdMouseEvent -> IO ()) + mouseEventCB :: Maybe (AosdPtr -> C'AosdMouseEvent -> IO ()) } toAosdTransparency :: Transparency -> C'AosdTransparency diff --git a/Graphics/Aosd/Util.hs b/Graphics/Aosd/Util.hs --- a/Graphics/Aosd/Util.hs +++ b/Graphics/Aosd/Util.hs @@ -10,10 +10,15 @@ import Foreign.Concurrent import Foreign.Ptr import Foreign.ForeignPtr(ForeignPtr) +import Data.Functor maybeDo :: Monad m => (a -> m ()) -> Maybe a -> m () maybeDo f = maybe (return ()) f +traverseMaybe :: Monad m => (t -> m a) -> Maybe t -> m (Maybe a) +traverseMaybe f Nothing = return Nothing +traverseMaybe f (Just x) = Just `liftM` f x + (^+^) :: (Num t) => (t, t) -> (t, t) -> (t, t) (x,y) ^+^ (x',y') = (x+x',y+y') @@ -105,3 +110,5 @@ finalizer) putDebugMemory cxt ("Created "++descr++" ForeignPtr: "++show fp) return fp + + diff --git a/Graphics/Aosd/XUtil.hs b/Graphics/Aosd/XUtil.hs --- a/Graphics/Aosd/XUtil.hs +++ b/Graphics/Aosd/XUtil.hs @@ -3,22 +3,18 @@ module Graphics.Aosd.XUtil where import Graphics.X11.Xlib.Display import Control.Exception +import Graphics.X11.Xlib -data ScreenSize = ScreenSize { screenWidth, screenHeight :: Int } +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... +getScreenSize :: Display -> IO ScreenSize +getScreenSize display = do 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,7 +2,7 @@ -- see -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. Name: aosd -Version: 0.1.3 +Version: 0.2.0 Synopsis: Bindings to libaosd, a library for Cairo-based on-screen displays Description: @@ -21,10 +21,11 @@ . markup = pSized 50 (pUnlines [pItalic \"AOSD\",\"Example\"]) . - main = aosdFlash - \ defaultOpts - \ (textRenderer markup) { alignment = Just AlignCenter, colour = orange } - \ (symDurations 3000 3000) + main = do + \ withAosd + \ defaultOpts + \ (textRenderer markup) { alignment = Just AlignCenter, colour = orange } + \ (\a -> aosdFlash a (symDurations 3000 3000)) @ . Tested with /libaosd/ version 0.2.7. @@ -57,6 +58,7 @@ Graphics.Aosd.Options Graphics.Aosd.Renderer Graphics.Aosd.Util + Graphics.Aosd.CallbackUtil Graphics.Aosd.XUtil diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -24,7 +24,8 @@ aosdHide header aosdLoopOnce header -go t r = aosdFlash defaultOpts r (symDurations 100 t) +go t r = withAosd defaultOpts r (\a -> aosdFlash a (symDurations 100 t)) + goText t f pm = go t (f (textRenderer pm)) tagsMarkup = pUnlines $(listE [ appE (varE (mkName n)) (litE (stringL n)) | n <- words "pBold pBig pItalic pStrikethrough pSmall pSub pSup pUnderline pMono"]) @@ -62,11 +63,11 @@ leftOverflowTest = sequence_ [ do print ("xPos",xPos) - aosdFlash + withAosd (defaultOpts {xPos}) (textRenderer txt) { alignment = Just AlignRight, width = Just 300, wrapMode = Just WrapWholeWords } - (symDurations 100 3000) + (flip aosdFlash (symDurations 100 3000)) | xPos <- [Center,Min,Max] ] where @@ -89,7 +90,7 @@ where f xPos yPos = do let tr = (textRenderer (pText $ show (xPos,yPos))) { colour = red } - aosdFlash defaultOpts { xPos, yPos } tr (symDurations 500 dur) + withAosd defaultOpts { xPos, yPos } tr (flip aosdFlash (symDurations 500 dur)) forEachPos f = do @@ -110,7 +111,7 @@ circleTest = forEachPos doCircle -doCircle xPos yPos = aosdFlash defaultOpts { xPos, yPos } GeneralRenderer{..} (symDurations 100 2000) +doCircle xPos yPos = withAosd defaultOpts { xPos, yPos } GeneralRenderer{..} (flip aosdFlash (symDurations 100 2000)) where grInkExtent = Rectangle (-r) (-r) (2*r) (2*r) grPositioningExtent = Rectangle (-r_half) (-r_half) r r @@ -134,3 +135,20 @@ transparencyTest = goText 3000 (\s -> s { colour = lime, opacity = 0.5 }) (pSized 100 "Transparency") + + +mouseEventTest = do + let initialRen = textRenderer $ pSized 30 "Click me" + + + let f aosd ev = do + reconfigure opts (textRenderer (pShow ev)) { colour = white, width = Just 400 } aosd + aosdRender aosd + + opts = defaultOpts { mouseEventCB = Just f, hideUponMouseEvent = Just False } + + + aosd <- aosdNew opts initialRen + + aosdFlash aosd (symDurations 100 10000) + aosdDestroy aosd