aosd 0.1.3 → 0.2.0

raw patch · 8 files changed

+186/−131 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Graphics/Aosd.hs +101/−112
• Graphics/Aosd.hs-boot +2/−0
• Graphics/Aosd/CallbackUtil.hs +40/−0
• Graphics/Aosd/Options.hs +2/−1
• Graphics/Aosd/Util.hs +7/−0
• Graphics/Aosd/XUtil.hs +4/−8
• aosd.cabal +7/−5
• test/test.hs +23/−5

@@ -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

@@ -0,0 +1,2 @@+module Graphics.Aosd where+data AosdPtr

@@ -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+

@@ -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

@@ -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++

@@ -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 

@@ -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:  <http://www.atheme.org/project/libaosd>@@ -21,10 +21,11 @@  .  markup = pSized 50 (pUnlines [pItalic \"AOSD\",\"Example\"])  .- main = aosdFlash- \           defaultOpts- \           (textRenderer markup) &#123; alignment = Just AlignCenter, colour = orange &#125;- \           (symDurations 3000 3000)+ main = do+ \    withAosd+ \        defaultOpts + \        (textRenderer markup) &#123; alignment = Just AlignCenter, colour = orange &#125;+ \        (\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  

@@ -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