aosd-0.1.3: Graphics/Aosd.hs
{-# 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(..),
-- -- ** Simple combinators
-- HCatRenderer(..), VCatRenderer(..),
-- * Options
AosdOptions(..), Transparency(..), Position(..), XClassHint(..), defaultOpts,
-- * Displaying
aosdFlash,
FlashDurations(..), symDurations,
-- ** Low-level operations
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.Trans.Reader
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,Cairo)
import Graphics.Rendering.Pango.Enums
import System.IO.Unsafe
-- toAosdCoordinate :: Position -> C'AosdCoordinate
-- toAosdCoordinate Min = c'COORDINATE_MINIMUM
-- toAosdCoordinate Center = c'COORDINATE_CENTER
-- toAosdCoordinate Max = c'COORDINATE_MAXIMUM
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")
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
)
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
{-
(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
If xPos is Min, we want:
screenx lp = 0
<=>
windowLeft + lp - li = 0
<=>
windowLeft = li - lp
If xPos is Center, we want:
screenx (lp + wp/2) = screenWidth/2
<=>
windowLeft + (lp + wp/2) - li = screenWidth/2
<=>
windowLeft = li - lp + (screenWidth - wp)/2
If xPos is Max, we want:
screenx (lp+wp) = screenWidth
<=>
windowLeft + (lp+wp) - li = screenWidth
<=>
windowLeft = li - lp + screenWidth - wp
-}
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
windowLeft = calculateOffsetAdjustment xPos li lp wp screenWidth + fst offset
windowTop = calculateOffsetAdjustment yPos ti tp hp screenHeight + snd offset
windowWidth = fromIntegral wi
windowHeight = fromIntegral hi
finalRenderer = do
translate (fi . negate $ li) (fi . negate $ ti)
grRender
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 } =
withCString resName (\resName' ->
withCString resClass (\resClass' ->
c'aosd_set_names a resName' resClass'))
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
-- | 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)
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:
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) ...
thunk -- Causes the C side to pass a dead StablePtr back to @theC'AosdRenderer@!
-}
return AosdForeignPtr {unAosdPtr,aosdStructOwnedDataVar}
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