A very minor haddock tweak in for callbacks.

Ignore-this: b867cabbda8b6bb0aa821421c40ba05c

darcs-hash:20090308135818-ed7c9-fb655fc018bb2b40193ed067d2c6b0d70aff17f1.gz

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>
-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>

-- | A very low-level interface to Expat. Unless you need extreme speed, this
-- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree".
-- Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..), XMLParseError(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import Control.Parallel.Strategies
import Control.Monad
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

instance Show Parser where
    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True

-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.   It returns Nothing on success, or Just the parse error.
parseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
parseChunk parser xml final = do
    ok <- withHandlers parser $ doParseChunk parser xml final
    if ok
        then return Nothing
        else Just `fmap` getError parser

getError parser = withParser parser $ \p -> do
                code <- xmlGetErrorCode p
                cerr <- xmlErrorString code
                err <- peekCString cerr
                line <- xmlGetCurrentLineNumber p
                col <- xmlGetCurrentColumnNumber p
                return $ XMLParseError err
                    (fromIntegral line) (fromIntegral col)

withHandlers :: Parser -> IO a -> IO a
withHandlers parser@(Parser fp startRef endRef charRef) code = do
    bracket
        (do
            cStartH <- mkCStartElementHandler =<< readIORef startRef
            cEndH   <- mkCEndElementHandler =<< readIORef endRef
            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
            withParser parser $ \p -> do
                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
            return (cStartH, cEndH, cCharH))
        (\(cStartH, cEndH, cCharH) -> do
            freeHaskellFunPtr cStartH
            freeHaskellFunPtr cEndH
            freeHaskellFunPtr cCharH)
        (\_ -> code)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- | Parse error, consisting of message text, line number, and column number
data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show)

instance NFData XMLParseError where
    rnf (XMLParseError msg lin col) = rnf (msg, lin, col)

-- |@parse data@ feeds /lazy/ bytestring data into a parser. It returns Nothing
-- on success, or Just the parse error.
parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)
parse parser@(Parser _ _ _ _) bs = withHandlers parser $ feedChunk (BSL.toChunks bs)
  where
    feedChunk []      = return Nothing
    feedChunk (c:cs)  = do
        ok <- doParseChunk parser c (null cs)
        if ok
            then feedChunk cs
            else Just `fmap` getError parser

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs. Return True
-- to continue parsing as normal, or False to terminate the parse.
type StartElementHandler  = CString -> [(CString, CString)] -> IO Bool
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name. Return True to continue parsing as normal, or False to
-- terminate the parse.
type EndElementHandler    = CString -> IO Bool
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text. Return True to continue
-- parsing as normal, or False to terminate the parse.
type CharacterDataHandler = CStringLen -> IO Bool

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString
    :: CInt -> IO CString
foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser
    :: ParserPtr -> CInt -> IO ()

foreign import ccall safe "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)

wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler
wrapStartElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname cattrs = do
        cattrlist <- peekArray0 nullPtr cattrs
        stillRunning <- handler cname (pairwise cattrlist)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler =
    withParser parser $ \p -> do
        writeIORef startRef $ wrapStartElementHandler parser handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler
wrapEndElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname = do
        stillRunning <- handler cname
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler =
    withParser parser $ \p -> do
        writeIORef endRef $ wrapEndElementHandler parser handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cdata len = do
        stillRunning <- handler (cdata, fromIntegral len)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- | Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =
    withParser parser $ \p -> do
        writeIORef charRef $ wrapCharacterDataHandler parser handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>
-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>

-- | A very low-level interface to Expat. Unless you need extreme speed, this
-- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree".
-- Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..), XMLParseError(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import Control.Parallel.Strategies
import Control.Monad
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

instance Show Parser where
    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True

-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.   It returns Nothing on success, or Just the parse error.
parseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
parseChunk parser xml final = do
    ok <- withHandlers parser $ doParseChunk parser xml final
    if ok
        then return Nothing
        else Just `fmap` getError parser

getError parser = withParser parser $ \p -> do
                code <- xmlGetErrorCode p
                cerr <- xmlErrorString code
                err <- peekCString cerr
                line <- xmlGetCurrentLineNumber p
                col <- xmlGetCurrentColumnNumber p
                return $ XMLParseError err
                    (fromIntegral line) (fromIntegral col)

withHandlers :: Parser -> IO a -> IO a
withHandlers parser@(Parser fp startRef endRef charRef) code = do
    bracket
        (do
            cStartH <- mkCStartElementHandler =<< readIORef startRef
            cEndH   <- mkCEndElementHandler =<< readIORef endRef
            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
            withParser parser $ \p -> do
                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
            return (cStartH, cEndH, cCharH))
        (\(cStartH, cEndH, cCharH) -> do
            freeHaskellFunPtr cStartH
            freeHaskellFunPtr cEndH
            freeHaskellFunPtr cCharH)
        (\_ -> code)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- | Parse error, consisting of message text, line number, and column number
data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show)

instance NFData XMLParseError where
    rnf (XMLParseError msg lin col) = rnf (msg, lin, col)

-- |@parse data@ feeds /lazy/ bytestring data into a parser. It returns Nothing
-- on success, or Just the parse error.
parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)
parse parser@(Parser _ _ _ _) bs = withHandlers parser $ feedChunk (BSL.toChunks bs)
  where
    feedChunk []      = return Nothing
    feedChunk (c:cs)  = do
        ok <- doParseChunk parser c (null cs)
        if ok
            then feedChunk cs
            else Just `fmap` getError parser

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs. Return False to terminate the parse.
type StartElementHandler  = CString -> [(CString, CString)] -> IO Bool
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name. Return False to terminate the parse.
type EndElementHandler    = CString -> IO Bool
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text. Return False to terminate the parse.
type CharacterDataHandler = CStringLen -> IO Bool

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber
    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)
foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString
    :: CInt -> IO CString
foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser
    :: ParserPtr -> CInt -> IO ()

foreign import ccall safe "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)

wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler
wrapStartElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname cattrs = do
        cattrlist <- peekArray0 nullPtr cattrs
        stillRunning <- handler cname (pairwise cattrlist)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler =
    withParser parser $ \p -> do
        writeIORef startRef $ wrapStartElementHandler parser handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler
wrapEndElementHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cname = do
        stillRunning <- handler cname
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler =
    withParser parser $ \p -> do
        writeIORef endRef $ wrapEndElementHandler parser handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h
  where
    h ptr cdata len = do
        stillRunning <- handler (cdata, fromIntegral len)
        unless stillRunning $
            withParser parser $ \p -> xmlStopParser p 0

-- | Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =
    withParser parser $ \p -> do
        writeIORef charRef $ wrapCharacterDataHandler parser handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []


gstreamer: more docs for M.S.G.Core.Bus

gstreamer: more docs for M.S.G.Core.Bus

darcs-hash:20080519004951-21862-34406132707946ab5cebc5248041c1fa9a8cce06.gz

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  An asynchronous message bus subsystem.
module Media.Streaming.GStreamer.Core.Bus (
-- * Detail
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.

-- * Types
  Bus,
  BusClass,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  busMessage,
  busSyncMessage,

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT          -- ^ @bus@ - a 'Bus'
            -> IO [BusFlags] -- ^ the flags set on @bus@
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT       -- ^ @bus@ - a 'Bus'
            -> [BusFlags] -- ^ the flags to set on @bus@
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT       -- ^ @bus@ - a 'Bus'
              -> [BusFlags] -- ^ the flags to unset on @bus@
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus -- ^ the newly created 'Bus' object
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT    -- ^ @bus@ - a 'Bus'
        -> Message -- ^ @message@ - the message to post
        -> IO Bool -- ^ 'True' if the message was posted, or
                   --   'False' if the bus is flushing
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT    -- ^ @bus@ - a 'Bus'
               -> IO Bool -- ^ 'True' if there are messages
                          --   on the bus to be handled, otherwise 'False'
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  Any message returned
--   will remain on the queue.
busPeek :: BusClass busT
        => busT               -- ^ @bus@ - a 'Bus'
        -> IO (Maybe Message) -- ^ the first 'Message' on the bus, or
                              --   'Nothing' if the bus is empty
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT               -- ^ @bus@ - a 'Bus'
       -> IO (Maybe Message) -- ^ the first 'Message' on the bus, or
                             --   'Nothing' if the bus is empty
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT               -- ^ @bus@ - a 'Bus'
            -> Maybe ClockTime    -- ^ @timeoutM@ - the time to wait for,
                                  --   or 'Nothing' to wait forever
            -> IO (Maybe Message) -- ^ the first message recieved, or
                                  --   'Nothing' if the timeout has expired
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT  -- ^ @bus@ - a 'Bus'
               -> Bool  -- ^ @flushing@ - the new flushing state
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up the FunPtr after
-- busSetSyncHandler.  gstreamer doesn't give us a nice way to do this
-- (such as a DestroyNotify pointer in the argument list)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT                 -- ^ @bus@ - a 'Bus'
                  -> Maybe BusSyncHandler -- ^ @busSyncHandlerM@ - the new 'BusSyncHandler'
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT  -- ^ @bus@ - a 'Bus'
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT      -- ^ @bus@ - a 'Bus'
               -> IO Source -- ^ the new event 'Source'
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT         -- ^ @bus@ - a 'Bus'
            -> Priority     -- ^ @priority@ - the priority of the watch
            -> BusFunc      -- ^ @func@ - the action to perform when a message is recieved
            -> IO HandlerId -- ^ the event source ID
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the 'busSyncMessage' signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT  -- ^ @bus@ - a 'Bus'
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the 'busSyncMessage' signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The 'busSyncMessage' signal comes from the thread
--   of whatever object posted the message; the 'busMessage' signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT  -- ^ @bus@ - a 'Bus'
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   'busMessage' signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT     -- ^ @bus@ - a 'Bus'
                  -> Priority -- ^ @priority@ - the priority of the watch
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT  -- ^ @bus@ - a 'Bus'
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the 'busMessage' signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   'busMessage' signal to be emitted for every message that the
--   function sees. Thus, a 'busMessage' signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: BusClass busT
        => busT          -- ^ @bus@ - a 'Bus'
        -> [MessageType] -- ^ @events@ - the set of messages to poll for
        -> ClockTimeDiff -- ^ @timeout@ - the time to wait, or -1 to wait indefinitely
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} (toBus bus)
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | A message has been posted on the bus. This signal is emitted from
--   a 'Source' added to the 'MainLoop', and only when it is running.
busMessage :: BusClass busT
           => Signal busT (Message -> IO ())
busMessage =
    Signal $ connect_BOXED__NONE "message" peekMiniObject

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
busSyncMessage :: BusClass busT
               => Signal busT (Message -> IO ())
busSyncMessage =
    Signal $ connect_BOXED__NONE "sync-message" peekMiniObject

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  An asynchronous message bus subsystem.
module Media.Streaming.GStreamer.Core.Bus (
-- * Detail
  -- | The 'Bus' is resposible for delivering 'Message's in a
  --   first-in, first-out order, from the streaming threads to the
  --   application.
  --
  --   Since the application typically only wants to deal with
  --   delivery of these messages from one thread, the 'Bus' will
  --   marshal the messages between different threads. This is
  --   important since the actual streaming of media is done in
  --   a thread separate from the application.
  --
  --   The 'Bus' provides support for 'System.Glib.MainLoop.Source'
  --   based notifications. This makes it possible to handle the
  --   delivery in the GLib 'System.Glib.MainLoop.Source'.
  --
  --   A message is posted on the bus with the 'busPost' method. With
  --   the 'busPeek' and 'busPop' methods one can look at or retrieve
  --   a previously posted message.
  --
  --   The bus can be polled with the 'busPoll' method. This methods
  --   blocks up to the specified timeout value until one of the
  --   specified messages types is posted on the bus. The application
  --   can then pop the messages from the bus to handle
  --   them. Alternatively the application can register an
  --   asynchronous bus function using 'busAddWatch'. This function
  --   will install a 'System.Glib.MainLoop.Source' in the default
  --   GLib main loop and will deliver messages a short while after
  --   they have been posted. Note that the main loop should be
  --   running for the asynchronous callbacks.
  --
  --   It is also possible to get messages from the bus without any
  --   thread marshalling with the 'busSetSyncHandler' method. This
  --   makes it possible to react to a message in the same thread that
  --   posted the message on the bus. This should only be used if the
  --   application is able to deal with messages from different
  --   threads.
  --
  --   Every 'Pipeline' has one bus.
  --
  --   Note that a 'Pipeline' will set its bus into flushing state
  --   when changing from 'StateReady' to 'StateNull'.

-- * Types
  Bus,
  -- | The result of a 'BusSyncHandler'.
  BusSyncReply,
  -- | A handler that will be invoked synchronously when a new message
  --   is injected into the bus. This function is mostly used internally.
  --   Only one sync handler may be attached to a given bus.
  BusSyncHandler,
  BusClass,
  castToBus,
  toBus,
-- * Bus Operations
  busGetFlags,
  busSetFlags,
  busUnsetFlags,
  busNew,
  busPost,
  busHavePending,
  busPeek,
  busPop,
  busTimedPop,
  busSetFlushing,
  busSetSyncHandler,
  busUseSyncSignalHandler,
  busCreateWatch,
  busAddWatch,
  busDisableSyncMessageEmission,
  busEnableSyncMessageEmission,
  busAddSignalWatch,
  busRemoveSignalWatch,
  busPoll,

-- * Bus Signals
  busMessage,
  busSyncMessage,

  ) where

import Control.Monad ( liftM
                     , when )
{#import Media.Streaming.GStreamer.Core.Object#}
{#import Media.Streaming.GStreamer.Core.Types#}
{#import Media.Streaming.GStreamer.Core.Signals#}
{#import System.Glib.MainLoop#}
import System.Glib.Flags
import System.Glib.FFI
{#import System.Glib.GObject#}
{#import System.Glib.MainLoop#}

{# context lib = "gstreamer" prefix = "gst" #}

-- | Get the flags set on this bus.
busGetFlags :: BusClass busT
            => busT
            -> IO [BusFlags]
busGetFlags = mkObjectGetFlags

-- | Set flags on this bus.
busSetFlags :: BusClass busT
            => busT
            -> [BusFlags]
            -> IO ()
busSetFlags = mkObjectSetFlags

-- | Unset flags on this bus.
busUnsetFlags :: BusClass busT
              => busT
              -> [BusFlags]
              -> IO ()
busUnsetFlags = mkObjectUnsetFlags

-- | Create a new bus.
busNew :: IO Bus
busNew =
    {# call bus_new #} >>= takeObject

-- | Post a message to the bus.
busPost :: BusClass busT
        => busT
        -> Message
        -> IO Bool
busPost bus message =
    do {# call gst_mini_object_ref #} (toMiniObject message)
       liftM toBool $ {# call bus_post #} (toBus bus) message

-- | Check if there are pending messages on the bus.
busHavePending :: BusClass busT
               => busT
               -> IO Bool
busHavePending bus =
    liftM toBool $ {# call bus_have_pending #} $ toBus bus

-- | Get the message at the front of the queue.  It will remain on the
--   queue.
busPeek :: BusClass busT
        => busT
        -> IO (Maybe Message)
busPeek bus =
    {# call bus_peek #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get the message at the front of the queue.  It will be removed
--   from the queue.
busPop :: BusClass busT
       => busT
       -> IO (Maybe Message)
busPop bus =
    {# call bus_pop #} (toBus bus) >>= maybePeek takeMiniObject

-- | Get a message from the bus, waiting up to the specified timeout.
--   If the time given is 'Nothing', the function will wait forever.
--   If the time given is @0@, the function will behave like 'busPop'.
busTimedPop :: BusClass busT
            => busT
            -> Maybe ClockTime
            -> IO (Maybe Message)
busTimedPop bus timeoutM =
    let timeout = case timeoutM of
                    Just timeout' -> timeout'
                    Nothing       -> clockTimeNone
    in {# call bus_timed_pop #} (toBus bus) (fromIntegral timeout) >>=
           maybePeek takeMiniObject

-- | If @flushing@ is 'True', the bus will flush out any queued
--   messages, as well as any future messages, until the function is
--   called with @flushing@ set to 'False'.
busSetFlushing :: BusClass busT
               => busT
               -> Bool
               -> IO ()
busSetFlushing bus flushing =
    {# call bus_set_flushing #} (toBus bus) $ fromBool flushing

-- these will leak memory, maybe one day we can set a destroy notifier...

type CBusSyncHandler =  Ptr Bus
                     -> Ptr Message
                     -> {# type gpointer #}
                     -> IO {# type GstBusSyncReply #}
marshalBusSyncHandler :: BusSyncHandler
                      -> IO {# type GstBusSyncHandler #}
marshalBusSyncHandler busSyncHandler =
    makeBusSyncHandler cBusSyncHandler
    where cBusSyncHandler :: CBusSyncHandler
          cBusSyncHandler busPtr messagePtr _ =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 reply <- busSyncHandler bus message
                 when (reply == BusDrop) $
                     {# call gst_mini_object_unref #} (toMiniObject message)
                 return $ fromIntegral $ fromEnum reply
foreign import ccall "wrapper"
    makeBusSyncHandler :: CBusSyncHandler
                       -> IO {# type GstBusSyncHandler #}

-- the following mess is necessary to clean up safely after busSetSyncHandler.
-- gstreamer doesn't give us a nice way to do this (such as a DestroyNotify)
weakNotifyQuark, funPtrQuark :: Quark
weakNotifyQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerWeakNotify"
funPtrQuark = unsafePerformIO $ quarkFromString "Gtk2HS::SyncHandlerFunPtr"

getWeakNotify :: BusClass busT
              => busT
              -> IO (Maybe GWeakNotify)
getWeakNotify = objectGetAttributeUnsafe weakNotifyQuark

setWeakNotify :: BusClass busT
              => busT
              -> Maybe GWeakNotify
              -> IO ()
setWeakNotify = objectSetAttribute weakNotifyQuark

getFunPtr :: BusClass busT
          => busT
          -> IO (Maybe {# type GstBusSyncHandler #})
getFunPtr = objectGetAttributeUnsafe funPtrQuark

setFunPtr :: BusClass busT
          => busT
          -> Maybe {# type GstBusSyncHandler #}
          -> IO ()
setFunPtr = objectSetAttribute funPtrQuark

unsetSyncHandler :: BusClass busT
                 => busT
                 -> IO ()
unsetSyncHandler bus = do
  {# call bus_set_sync_handler #} (toBus bus) nullFunPtr nullPtr
  oldWeakNotifyM <- getWeakNotify bus
  case oldWeakNotifyM of
    Just oldWeakNotify -> objectWeakunref bus oldWeakNotify
    Nothing            -> return ()
  setWeakNotify bus Nothing
  oldFunPtrM <- getFunPtr bus
  case oldFunPtrM of
    Just oldFunPtr -> freeHaskellFunPtr oldFunPtr
    Nothing        -> return ()
  setFunPtr bus Nothing

-- | Set the synchronous message handler on the bus. The function will
--   be called every time a new message is posted to the bus. Note
--   that the function will be called from the thread context of the
--   poster.
--
--   Calling this function will replace any previously set sync
--   handler. If 'Nothing' is passed to this function, it will unset
--   the handler.
busSetSyncHandler :: BusClass busT
                  => busT
                  -> Maybe BusSyncHandler
                  -> IO ()
busSetSyncHandler bus busSyncHandlerM = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    case busSyncHandlerM of
      Just busSyncHandler ->
          do funPtr <- marshalBusSyncHandler busSyncHandler
             setFunPtr bus $ Just funPtr
             weakNotify <- objectWeakref bus $ freeHaskellFunPtr funPtr
             setWeakNotify bus $ Just weakNotify
             {# call bus_set_sync_handler #} (toBus bus) funPtr nullPtr
      Nothing ->
          return ()

-- | Use a synchronous message handler that converts all messages to signals.
busUseSyncSignalHandler :: BusClass busT
                        => busT
                        -> IO ()
busUseSyncSignalHandler bus = do
  objectWithLock bus $ do
    unsetSyncHandler bus
    {# call bus_set_sync_handler #} (toBus bus) cBusSyncSignalHandlerPtr nullPtr
foreign import ccall unsafe "&gst_bus_sync_signal_handler"
    cBusSyncSignalHandlerPtr :: {# type GstBusSyncHandler #}

-- | Create a watch for the bus. The 'Source' will dispatch a signal
--   whenever a message is on the bus. After the signal is dispatched,
--   the message is popped off the bus.
busCreateWatch :: BusClass busT
               => busT
               -> IO Source
busCreateWatch bus =
    liftM Source $ {# call bus_create_watch #} (toBus bus) >>=
        flip newForeignPtr sourceFinalizer
foreign import ccall unsafe "&g_source_unref"
    sourceFinalizer :: FunPtr (Ptr Source -> IO ())

type CBusFunc =  Ptr Bus
              -> Ptr Message
              -> {# type gpointer #}
              -> IO {# type gboolean #}
marshalBusFunc :: BusFunc
               -> IO {# type GstBusFunc #}
marshalBusFunc busFunc =
    makeBusFunc cBusFunc
    where cBusFunc :: CBusFunc
          cBusFunc busPtr messagePtr userData =
              do bus <- peekObject busPtr
                 message <- peekMiniObject messagePtr
                 liftM fromBool $ busFunc bus message
foreign import ccall "wrapper"
    makeBusFunc :: CBusFunc
                -> IO {# type GstBusFunc #}

-- | Adds a bus watch to the default main context with the given
--   priority. This function is used to receive asynchronous messages
--   in the main loop.
--
--   The watch can be removed by calling 'System.Glib.MainLoop.sourceRemove'.
busAddWatch :: BusClass busT
            => busT
            -> Priority
            -> BusFunc
            -> IO HandlerId
busAddWatch bus priority func =
    do busFuncPtr <- marshalBusFunc func
       destroyNotify <- mkFunPtrDestroyNotify busFuncPtr
       liftM fromIntegral $
           {# call bus_add_watch_full #}
               (toBus bus)
               (fromIntegral priority)
               busFuncPtr
               nullPtr
               destroyNotify

-- | Instructs GStreamer to stop emitting the 'busSyncMessage' signal
--   for this bus. See 'busEnableSyncMessageEmission' for more
--   information.
--
--   In the event that multiple pieces of code have called
--   'busEnableSyncMessageEmission', the sync-message
--   emissions will only be stopped after all calls to
--   'busEnableSyncMessageEmission' were "cancelled" by
--   calling this function.
busDisableSyncMessageEmission :: BusClass busT
                              => busT
                              -> IO ()
busDisableSyncMessageEmission =
    {# call bus_disable_sync_message_emission #} . toBus

-- | Instructs GStreamer to emit the 'busSyncMessage' signal after
--   running the bus's sync handler. This function is here so that
--   programmers can ensure that they can synchronously receive
--   messages without having to affect what the bin's sync handler is.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busDisableSyncMessageEmission'
--   as many times as this function is called.
--
--   While this function looks similar to 'busAddSignalWatch', it is
--   not exactly the same -- this function enables synchronous
--   emission of signals when messages arrive; 'busAddSignalWatch'
--   adds an idle callback to pop messages off the bus
--   asynchronously. The 'busSyncMessage' signal comes from the thread
--   of whatever object posted the message; the 'busMessage' signal is
--   marshalled to the main thread via the main loop.
busEnableSyncMessageEmission :: BusClass busT
                             => busT
                             -> IO ()
busEnableSyncMessageEmission =
    {# call bus_enable_sync_message_emission #} . toBus

-- | Adds a bus signal watch to the default main context with the
--   given priority. After calling this method, the bus will emit the
--   'busMessage' signal for each message posted on the bus.
--
--   This function may be called multiple times. To clean up, the
--   caller is responsible for calling 'busRemoveSignalWatch' as many
--   times.
busAddSignalWatch :: BusClass busT
                  => busT
                  -> Priority
                  -> IO ()
busAddSignalWatch bus priority =
    {# call bus_add_signal_watch_full #} (toBus bus) $ fromIntegral priority

-- | Remove the signal watch that was added with 'busAddSignalWatch'.
busRemoveSignalWatch :: BusClass busT
                     => busT
                     -> IO ()
busRemoveSignalWatch =
    {# call bus_remove_signal_watch #} . toBus

-- | Poll the bus for a message. Will block while waiting for messages
--   to come. You can specify the maximum amount of time to wait with
--   the @timeout@ parameter. If @timeout@ is negative, the function
--   will wait indefinitely.
--
--   Messages not in @events@ will be popped off the bus and ignored.
--
--   Because 'busPoll' is implemented using the 'busMessage' signal
--   enabled by 'busAddSignalWatch', calling 'busPoll' will cause the
--   'busMessage' signal to be emitted for every message that the
--   function sees. Thus, a 'busMessage' signal handler will see every
--   message that 'busPoll' sees -- neither will steal messages from
--   the other.
--
--   This function will run a main loop in the default main context
--   while polling.
busPoll :: Bus
        -> [MessageType]
        -> ClockTimeDiff
        -> IO Message
busPoll bus events timeout =
    {# call bus_poll #} bus
                        (fromIntegral $ fromFlags events)
                        (fromIntegral timeout) >>=
        takeMiniObject

-- | A message has been posted on the bus. This signal is emitted from
--   a 'Source' added to the 'MainLoop', and only when it is running.
busMessage :: BusClass bus
           => Signal bus (Message -> IO ())
busMessage =
    Signal $ connect_BOXED__NONE "message" peekMiniObject

-- | A message has been posted on the bus. This signal is emitted from
--   the thread that posted the message so one has to be careful with
--   locking.
--
--   This signal will not be emitted by default, you must first call
--   'busUseSyncSignalHandler' if you want this signal to be emitted
--   when a message is posted on the bus.
busSyncMessage :: BusClass bus
               => Signal bus (Message -> IO ())
busSyncMessage =
    Signal $ connect_BOXED__NONE "sync-message" peekMiniObject


gstreamer: more docs for M.S.G.Core.Bus

gstreamer: more docs for M.S.G.Core.Bus


glib: make module name for GDateTime the same as the filename :)

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module System.Glib.GDateTime (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr

-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Peter Gavin
--
--  Created: 19 March 2002
--
--  Copyright (C) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module System.Glib.GDate (
  GTimeValPart,
  GTimeVal(..),
  gGetCurrentTime,
  gUSleep,
  gTimeValAdd,
  gTimeValFromISO8601,
  gTimeValToISO8601,
  GDate(..),
  GDateDay,
  GDateMonth,
  GDateYear,
  GDateJulianDay,
  GDateWeekday,
  gDateValidJulian,
  gDateValidDMY,
  gDateNewJulian,
  gDateNewDMY,
  gDateSetDay,
  gDateSetMonth,
  gDateSetYear,
  gDateNewTimeVal,
  gDateParse,
  gDateAddDays,
  gDateSubtractDays,
  gDateAddMonths,
  gDateSubtractMonths,
  gDateAddYears,
  gDateSubtractYears,
  gDateDaysBetween,
  gDateCompare,
  gDateClamp,
  gDateDay,
  gDateMonth,
  gDateYear,
  gDateWeekday
  ) where

import Control.Monad (liftM)
import System.Glib.FFI
import System.Glib.UTFString

type GTimeValPart = {# type glong #}
data GTimeVal = GTimeVal { gTimeValSec  :: GTimeValPart
                         , gTimeValUSec :: GTimeValPart }
                deriving (Eq, Ord)
instance Storable GTimeVal where
    sizeOf _ = {# sizeof GTimeVal #}
    alignment _ = alignment (undefined :: CString)
    peek ptr =
        do sec <- {# get GTimeVal->tv_sec #} ptr
           uSec <- {# get GTimeVal->tv_usec #} ptr
           return $ GTimeVal sec uSec
    poke ptr (GTimeVal sec uSec) =
        do {# set GTimeVal->tv_sec #} ptr sec
           {# set GTimeVal->tv_usec #} ptr uSec

gGetCurrentTime :: IO GTimeVal
gGetCurrentTime =
    alloca $ \ptr ->
        do {# call g_get_current_time #} $ castPtr ptr
           peek ptr

gUSleep :: GTimeValPart
        -> IO ()
gUSleep microseconds =
    {# call g_usleep #} $ fromIntegral microseconds

gTimeValAdd :: GTimeVal
            -> GTimeValPart
            -> GTimeVal
gTimeValAdd time microseconds =
    unsafePerformIO $ with time $ \ptr ->
        do {# call g_time_val_add #} (castPtr ptr) microseconds
           peek ptr

gTimeValFromISO8601 :: String
                    -> Maybe GTimeVal
gTimeValFromISO8601 isoDate =
    unsafePerformIO $ withUTFString isoDate $ \cISODate ->
        alloca $ \ptr ->
            do success <- liftM toBool $ {# call g_time_val_from_iso8601 #} cISODate $ castPtr ptr
               if success
                   then liftM Just $ peek ptr
                   else return Nothing

gTimeValToISO8601 :: GTimeVal
                  -> String
gTimeValToISO8601 time =
    unsafePerformIO $ with time $ \ptr ->
        {# call g_time_val_to_iso8601 #} (castPtr ptr) >>= readUTFString

newtype GDateDay = GDateDay {# type GDateDay #}
    deriving (Eq, Ord)
instance Bounded GDateDay where
    minBound = GDateDay 1
    maxBound = GDateDay 31

{# enum GDateMonth {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateMonth where
    minBound = GDateJanuary
    maxBound = GDateDecember

newtype GDateYear = GDateYear {# type GDateYear #}
    deriving (Eq, Ord)
instance Bounded GDateYear where
    minBound = GDateYear 1
    maxBound = GDateYear (maxBound :: {# type guint16 #})

type GDateJulianDay = {# type guint32 #}
newtype GDate = GDate { gDateJulianDay :: GDateJulianDay }
    deriving (Eq)
instance Storable GDate where
    sizeOf _ = {# sizeof GDate #}
    alignment _ = alignment (undefined :: CString)
    peek =
        (liftM (GDate . fromIntegral)) . {# call g_date_get_julian #} . castPtr
    poke ptr val =
        {# call g_date_set_julian #} (castPtr ptr) $ gDateJulianDay val

{# enum GDateWeekday {underscoreToCase} deriving (Eq, Ord) #}
instance Bounded GDateWeekday where
    minBound = GDateMonday
    maxBound = GDateSunday

gDateValidJulian :: GDateJulianDay
                 -> Bool
gDateValidJulian =
    toBool . {# call fun g_date_valid_julian #}

gDateValidDMY :: GDateDay
              -> GDateMonth
              -> GDateYear
              -> Bool
gDateValidDMY (GDateDay day) month (GDateYear year) =
    toBool $ {# call fun g_date_valid_dmy #} day
                                             (fromIntegral $ fromEnum month)
                                             year

gDateNewJulian :: GDateJulianDay
               -> Maybe GDate
gDateNewJulian julian =
    if gDateValidJulian julian
        then Just $ GDate julian
        else Nothing

gDateNewDMY :: GDateDay
            -> GDateMonth
            -> GDateYear
            -> Maybe GDate
gDateNewDMY day month year =
    if gDateValidDMY day month year
        then Just $ unsafePerformIO $ alloca $ \ptr ->
            do let GDateDay day' = day
                   GDateYear year' = year
               {# call g_date_set_dmy #} (castPtr ptr)
                                         day'
                                         (fromIntegral $ fromEnum month)
                                         year'
               peek ptr
        else Nothing

gDateSetDay :: GDate
            -> GDateDay
            -> Maybe GDate
gDateSetDay date (GDateDay day) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_day #} (castPtr ptr) day
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetMonth :: GDate
              -> GDateMonth
              -> Maybe GDate
gDateSetMonth date month =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_month #} (castPtr ptr) $ fromIntegral $ fromEnum month
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateSetYear :: GDate
             -> GDateYear
             -> Maybe GDate
gDateSetYear date (GDateYear year) =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_set_year #} (castPtr ptr) year
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateNewTimeVal :: GTimeVal
                -> GDate
gDateNewTimeVal timeVal =
    unsafePerformIO $ alloca $ \ptr ->
        with timeVal $ \timeValPtr ->
        do {# call g_date_set_time_val #} (castPtr ptr) $ castPtr timeValPtr
           peek ptr

gDateParse :: String
           -> IO (Maybe GDate)
gDateParse str =
    alloca $ \ptr ->
        do withUTFString str $ {# call g_date_set_parse #} $ castPtr ptr
           valid <- liftM toBool $ {# call g_date_valid #} $ castPtr ptr
           if valid
               then liftM Just $ peek ptr
               else return Nothing

gDateAddDays :: GDate
             -> Word
             -> GDate
gDateAddDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateSubtractDays :: GDate
                  -> Word
                  -> GDate
gDateSubtractDays date nDays =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_days #} (castPtr ptr) $ fromIntegral nDays
           peek ptr

gDateAddMonths :: GDate
               -> Word
               -> GDate
gDateAddMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateSubtractMonths :: GDate
                    -> Word
                    -> GDate
gDateSubtractMonths date nMonths =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_months #} (castPtr ptr) $ fromIntegral nMonths
           peek ptr

gDateAddYears :: GDate
              -> Word
              -> GDate
gDateAddYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_add_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateSubtractYears :: GDate
                   -> Word
                   -> GDate
gDateSubtractYears date nYears =
    unsafePerformIO $ with date $ \ptr ->
        do {# call g_date_subtract_years #} (castPtr ptr) $ fromIntegral nYears
           peek ptr

gDateDaysBetween :: GDate
                 -> GDate
                 -> Int
gDateDaysBetween date1 date2 =
    fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
        with date2 $ \ptr2 ->
            {# call g_date_days_between #} (castPtr ptr1) $ castPtr ptr2

gDateCompare :: GDate
             -> GDate
             -> Ordering
gDateCompare date1 date2 =
    let result = fromIntegral $ unsafePerformIO $ with date1 $ \ptr1 ->
                     with date2 $ \ptr2 ->
                         {# call g_date_compare #} (castPtr ptr1) $ castPtr ptr2
        ordering | result < 0 = LT
                 | result > 0 = GT
                 | otherwise  = EQ
    in ordering

instance Ord GDate where
    compare = gDateCompare

gDateClamp :: GDate
           -> GDate
           -> GDate
           -> GDate
gDateClamp date minDate maxDate =
    unsafePerformIO $ with date $ \ptr ->
        with minDate $ \minPtr ->
            with maxDate $ \maxPtr ->
                do {# call g_date_clamp #} (castPtr ptr) (castPtr minPtr) $ castPtr maxPtr
                   peek ptr

gDateDay :: GDate
         -> GDateDay
gDateDay date =
    GDateDay $ unsafePerformIO $ with date $ {# call g_date_get_day #} . castPtr

gDateMonth :: GDate
           -> GDateMonth
gDateMonth date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_month #} . castPtr

gDateYear :: GDate
          -> GDateYear
gDateYear date =
    GDateYear $ unsafePerformIO $ with date $ {# call g_date_get_year #} . castPtr

gDateWeekday :: GDate
             -> GDateWeekday
gDateWeekday date =
    toEnum $ fromIntegral $ unsafePerformIO $ with date $ {# call g_date_get_weekday #} . castPtr


gstreamer: more docs in M.S.G.Core.Caps

gstreamer: more docs in M.S.G.Core.Caps

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A structure describing sets of media formats.
module Media.Streaming.GStreamer.Core.Caps (

-- * Detail
  -- | 'Caps' (short for /capabilities/) are lightweight objects
  --   describing media types. They are composed of arrays of
  --   'Structure's.
  --
  --   'Caps' are exposed on 'PadTemplate's to describe all the
  --   possible types a given 'Pad' can handle. They are also stored
  --   in the 'Registry' along with the description of an 'Element'.
  --
  --   'Caps' can be retrieved from an 'Element'\'s 'Pad's using the
  --   'padGetCaps' function. The returned 'Caps' describes the possible
  --   types that the pad can handle or produce at runtime.
  --
  --   'Caps' are also attached to 'Buffers' to describe the type of
  --   the contained data using the function 'bufferSetCaps'. 'Caps'
  --   attached to a buffer allow for format negotiation upstream and
  --   downstream.
  --
  --   'Caps' are /fixed/ when they have no properties with ranges or
  --   lists. Use 'capsIsFixed' to test for fixed caps. Only fixed
  --   caps may be set on a 'Pad' or 'Buffer'.

-- * Types
  Caps,
  capsNone,
  capsAny,

-- * Caps Operations
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

-- * Caps Mutation
  CapsM,
  capsCreate,
  capsModify,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

{# context lib = "gstreamer" prefix = "gst" #}

import Control.Monad (liftM)
import Control.Monad.Reader
import System.Glib.FFI
import System.Glib.UTFString
{#import Media.Streaming.GStreamer.Core.Types#}

-- | A 'Caps' that represents an undefined media type.
capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

-- | A 'Caps' that represents all possible media types.
capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

-- | Get the number of structures contained in the 'Caps'.
capsSize :: Caps -- ^ @caps@ - a 'Caps'
         -> Word -- ^ the number of structures contained in the 'Caps'
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

-- | Get the 'Structure' at the given index.
capsGetStructure :: Caps            -- ^ @caps@ - a 'Caps'
                 -> Word            -- ^ @index@ - the index of the 'Structure'
                 -> Maybe Structure -- ^ the 'Structure' at the given index, or 'Nothing'
                                    --   if @index@ is invalid
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

-- | Create a new 'Caps' containing only the 'Structure' at the given
--   index of the caps.
capsCopyNth :: Caps       -- ^ @caps@ - a 'Caps'
            -> Word       -- ^ @index@ - the index of the 'Structure'
            -> Maybe Caps -- ^ the new 'Caps', or 'Nothing'
                          --   if @index@ is invalid
capsCopyNth caps index =
    unsafePerformIO $
        {# call caps_copy_nth #} caps (fromIntegral index) >>=
            maybePeek takeCaps

-- | Determine whether @caps@ represents no media formats.
capsIsEmpty :: Caps -- ^ @caps@ - a 'Caps'
            -> Bool -- ^ 'True' if @caps@ is empty, otherwise 'False'
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

-- | Determine whether the @caps@ is fixed; that is, if it has exactly
--   one structure, and each field in the structure describes a fixed type.
capsIsFixed :: Caps -- ^ @caps@ - a 'Caps'
            -> Bool -- ^ 'True' if @caps@ is fixed, otherwise 'False'
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

-- | Returns 'True' if the caps represent the same set of capabilities.
--
--   This function does not work reliably if optional properties for
--   'Caps' are included on one 'Caps' but omitted on the other.
capsIsEqual :: Caps -- ^ @caps1@ - the first 'Caps'
            -> Caps -- ^ @caps2@ - the second 'Caps'
            -> Bool -- ^ 'True' if both 'Caps' represent the same set
                    --   of capabilities.
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

-- | Returns 'True' if the caps are equal.  The caps must both be
--   fixed.
capsIsEqualFixed :: Caps -- ^ @caps1@ - the first 'Caps'
                 -> Caps -- ^ @caps2@ - the second 'Caps'
                 -> Bool -- ^ 'True' if both 'Caps' represent the same set
                         --   of capabilities
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

-- | Returns 'True' if every media format in the first caps is also
--   contained by the second. That is, the first is a subset of the
--   second.
capsIsAlwaysCompatible :: Caps -- ^ @caps1@ - the first 'Caps'
                       -> Caps -- ^ @caps2@ - the second 'Caps'
                       -> Bool -- ^ 'True' if @caps1@ is a subset of @caps2@, otherwise 'False'
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

-- | Returns 'True' if all caps represented by the first argument are
--   also represented by the second.
--
--   This function does not work reliably if optional properties for
--   caps are included on one caps and omitted on the other.
capsIsSubset :: Caps -- ^ @caps1@ - the first 'Caps'
             -> Caps -- ^ @caps2@ - the second 'Caps'
             -> Bool -- ^ 'True' if @caps1@ is a subset of @caps2@, otherwise 'False'
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

-- | Creates a new caps containing all the formats that are common to
--   both of the caps.
capsIntersect :: Caps -- ^ @caps1@ - the first 'Caps'
              -> Caps -- ^ @caps2@ - the second 'Caps'
              -> Caps -- ^ a new 'Caps' containing all capabilities present
                      --   in both @caps1@ and @caps2@
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are common to
--   either of the caps. If either of the structures are equivalient
--   to 'capsAny', the result will be 'capsAny'.
capsUnion :: Caps -- ^ @caps1@ - the first 'Caps'
          -> Caps -- ^ @caps2@ - the second 'Caps'
          -> Caps -- ^ a new 'Caps' containing all capabilities present
                  --   in either @caps1@ and @caps2@
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are in the
--   first but not the second.
capsSubtract :: Caps -- ^ @caps1@ - the first 'Caps'
             -> Caps -- ^ @caps2@ - the second 'Caps'
             -> Caps -- ^ a new 'Caps' containing all capabilities present
                     --   in @caps1@ but not @caps2@
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps that represents the same set of formats as the
--   argument, but that contains no lists.
capsNormalize :: Caps -- ^ @caps@ - a 'Caps'
              -> Caps -- ^ the new, normalized 'Caps'
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

-- | Converts the argument to a string representation. The string can
--   be converted back to a caps using 'capsFromString'.
capsToString :: Caps   -- ^ @caps@ - a 'Caps'
             -> String -- ^ the string representation of 'Caps'
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

-- | Read a caps from a string.
capsFromString :: String     -- ^ @string@ - the string representation of a 'Caps'
               -> Maybe Caps -- ^ the new 'Caps', or 'Nothing' if @string@ is invalid
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            maybePeek takeCaps

-- | A 'Monad' for sequencing modifications to a 'Caps'.
newtype CapsM a =
    CapsM (ReaderT (Ptr Caps) IO a)
    deriving (Functor, Monad)

askCapsPtr :: CapsM (Ptr Caps)
askCapsPtr = CapsM $ ask

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           result <- runReaderT action ptr
           caps <- takeCaps ptr
           return (caps, result)

-- | Create a caps and mutate it according to the given action.
capsCreate :: CapsM a   -- ^ @mutate@ - the mutating action
           -> (Caps, a) -- ^ the new 'Caps' and the action's result
capsCreate mutate =
    marshalCapsModify
        {# call caps_new_empty #}
        mutate

-- | Copy a caps and mutate it according to the given action.
capsModify :: Caps      -- ^ @caps@ - the 'Caps' to modify
           -> CapsM a   -- ^ @mutate@ - the mutating action
           -> (Caps, a) -- ^ the new 'Caps' and the action's result
capsModify caps mutate =
    marshalCapsModify ({# call caps_copy #} caps) mutate

-- | Append the given structure to the current caps.
capsAppendStructure :: Structure -- ^ @structure@ - the 'Structure' to append to the current 'Caps'
                    -> CapsM ()
capsAppendStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_append_structure capsPtr structurePtr
  where _ = {# call caps_append_structure #}
        _ = {# call structure_copy #}

-- | Append the structure to the current caps, if it is not already
--   expressed by the caps.
capsMergeStructure :: Structure -- ^ @structure@ - the 'Structure' to merge with the current 'Caps'
                   -> CapsM ()
capsMergeStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_merge_structure capsPtr structurePtr
  where _ = {# call caps_merge_structure #}
        _ = {# call structure_copy #}

-- | Removes the structure at the given index from the current caps.
capsRemoveStructure :: Word     -- ^ @idx@ - the index of the 'Structure' to remove
                    -> CapsM ()
capsRemoveStructure idx = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_remove_structure capsPtr $ fromIntegral idx
  where _ = {# call caps_remove_structure #}

-- | Discard all but the first structure from the current caps.
capsTruncate :: CapsM ()
capsTruncate = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_truncate capsPtr
  where _ = {# call caps_truncate #}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
--  |
--  Maintainer  : gtk2hs-devel@lists.sourceforge.net
--  Stability   : alpha
--  Portability : portable (depends on GHC)
--
--  A structure describing sets of media formats.
module Media.Streaming.GStreamer.Core.Caps (

-- * Detail
  -- | 'Caps' (short for /capabilities/) are lightweight objects
  --   describing media types. They are composed of arrays of
  --   'Structure's.
  --
  --   'Caps' are exposed on 'PadTemplate's to describe all the
  --   possible types a given 'Pad' can handle. They are also stored
  --   in the 'Registry' along with the description of an 'Element'.
  --
  --   'Caps' can be retrieved from an 'Element'\'s 'Pad's using the
  --   'padGetCaps' function. The returned 'Caps' describes the possible
  --   types that the pad can handle or produce at runtime.
  --
  --   'Caps' are also attached to 'Buffers' to describe the type of
  --   the contained data using the function 'bufferSetCaps'. 'Caps'
  --   attached to a buffer allow for format negotiation upstream and
  --   downstream.
  --
  --   'Caps' are /fixed/ when they have no properties with ranges or
  --   lists. Use 'capsIsFixed' to test for fixed caps. Only fixed
  --   caps may be set on a 'Pad' or 'Buffer'.

-- * Types
  Caps,
  capsNone,
  capsAny,

-- * Caps Operations
  capsSize,
  capsGetStructure,
  capsIsEmpty,
  capsIsFixed,
  capsIsEqual,
  capsIsEqualFixed,
  capsIsAlwaysCompatible,
  capsIsSubset,
  capsIntersect,
  capsUnion,
  capsSubtract,
  capsNormalize,
  capsFromString,
  capsToString,

-- * Caps Mutation
  CapsM,
  capsCreate,
  capsModify,
  capsAppendStructure,
  capsMergeStructure,
  capsRemoveStructure,
  capsTruncate

  ) where

{# context lib = "gstreamer" prefix = "gst" #}

import Control.Monad (liftM)
import Control.Monad.Reader
import System.Glib.FFI
import System.Glib.UTFString
{#import Media.Streaming.GStreamer.Core.Types#}

-- | A 'Caps' that represents an undefined media type.
capsNone :: Caps
capsNone =
    unsafePerformIO $ {# call caps_new_empty #} >>= takeCaps

-- | A 'Caps' that represents all possible media types.
capsAny :: Caps
capsAny =
    unsafePerformIO $ {# call caps_new_any #} >>= takeCaps

-- | Returns the number of structures contained in the 'Caps'.
capsSize :: Caps
         -> Word
capsSize caps =
    fromIntegral $ unsafePerformIO $ {# call caps_get_size #} caps

-- | Returns the 'Structure' at the given index.
capsGetStructure :: Caps
                 -> Word
                 -> Maybe Structure
capsGetStructure caps index =
    unsafePerformIO $
        {# call caps_get_structure #} caps (fromIntegral index) >>=
            maybePeek peekStructure

-- | Returns a new 'Caps' containing only the 'Structure' at the given
--   index of the caps.
capsCopyNth :: Caps
            -> Word
            -> Maybe Caps
capsCopyNth caps index =
    unsafePerformIO $
        {# call caps_copy_nth #} caps (fromIntegral index) >>=
            maybePeek takeCaps

-- | Returns 'True' if the caps represents no media formats.
capsIsEmpty :: Caps
            -> Bool
capsIsEmpty caps =
    toBool $ unsafePerformIO $
        {# call caps_is_empty #} caps

-- | Returns 'True' if the caps is fixed.
capsIsFixed :: Caps
            -> Bool
capsIsFixed caps =
    toBool $ unsafePerformIO $
        {# call caps_is_fixed #} caps

-- | Returns 'True' if the caps represent the same set of capabilities.
capsIsEqual :: Caps
            -> Caps
            -> Bool
capsIsEqual caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal #} caps1 caps2

instance Eq Caps where
    (==) = capsIsEqual

-- | Returns 'True' if the caps are equal.  The caps must both be
--   fixed.
capsIsEqualFixed :: Caps
                 -> Caps
                 -> Bool
capsIsEqualFixed caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_equal_fixed #} caps1 caps2

-- | Returns 'True' if every media format in the first caps is also
--   contained by the second. That is, the first is a subset of the
--   second.
capsIsAlwaysCompatible :: Caps
                       -> Caps
                       -> Bool
capsIsAlwaysCompatible caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_always_compatible #} caps1 caps2

-- | Returns 'True' if all caps represented by the first argument are
--   also represented by the second.
--
--   This function does not work reliably if optional properties for
--   caps are included on one caps and omitted on the other.
capsIsSubset :: Caps
             -> Caps
             -> Bool
capsIsSubset caps1 caps2 =
    toBool $ unsafePerformIO $
        {# call caps_is_subset #} caps1 caps2

-- | Creates a new caps containing all the formats that are common to
--   both of the caps.
capsIntersect :: Caps
              -> Caps
              -> Caps
capsIntersect caps1 caps2 =
    unsafePerformIO $
        {# call caps_intersect #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are common to
--   either of the caps. If either of the structures are equivalient
--   to 'capsAny', the result will be 'capsAny'.
capsUnion :: Caps
          -> Caps
          -> Caps
capsUnion caps1 caps2 =
    unsafePerformIO $
        {# call caps_union #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps containing all the formats that are in the
--   first but not the second.
capsSubtract :: Caps
             -> Caps
             -> Caps
capsSubtract caps1 caps2 =
    unsafePerformIO $
        {# call caps_subtract #} caps1 caps2 >>=
            takeCaps

-- | Creates a new caps that represents the same set of formats as the
--   argument, but that contains no lists.
capsNormalize :: Caps
              -> Caps
capsNormalize caps =
    unsafePerformIO $
        {# call caps_normalize #} caps >>= takeCaps

-- | Converts the argument to a string representation. The string can
--   be converted back to a caps using 'capsFromString'.
capsToString :: Caps
             -> String
capsToString caps =
    unsafePerformIO $
        {# call caps_to_string #} caps >>= readUTFString

-- | Read a caps from a string.
capsFromString :: String
               -> Maybe Caps
capsFromString string =
    unsafePerformIO $
        withUTFString string {# call caps_from_string #} >>=
            maybePeek takeCaps

-- | A 'Monad' for sequencing modifications to a 'Caps'.
newtype CapsM a =
    CapsM (ReaderT (Ptr Caps) IO a)
    deriving (Functor, Monad)

askCapsPtr :: CapsM (Ptr Caps)
askCapsPtr = CapsM $ ask

marshalCapsModify :: IO (Ptr Caps)
                  -> CapsM a
                  -> (Caps, a)
marshalCapsModify mkCaps (CapsM action) =
    unsafePerformIO $
        do ptr <- mkCaps
           result <- runReaderT action ptr
           caps <- takeCaps ptr
           return (caps, result)

-- | Create a caps and mutate it according to the given action.
capsCreate :: CapsM a
           -> (Caps, a)
capsCreate action =
    marshalCapsModify
        {# call caps_new_empty #}
        action

-- | Copy a caps and mutate it according to the given action.
capsModify :: Caps
           -> CapsM a
           -> (Caps, a)
capsModify caps action =
    marshalCapsModify ({# call caps_copy #} caps) action

-- | Append the given structure to the current caps.
capsAppendStructure :: Structure
                    -> CapsM ()
capsAppendStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_append_structure capsPtr structurePtr
  where _ = {# call caps_append_structure #}
        _ = {# call structure_copy #}

-- | Append the structure to the current caps, if it is not already
--   expressed by the caps.
capsMergeStructure :: Structure
                   -> CapsM ()
capsMergeStructure structure = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ withStructure structure $ \structurePtr ->
      do structurePtr' <- gst_structure_copy structurePtr
         gst_caps_merge_structure capsPtr structurePtr
  where _ = {# call caps_merge_structure #}
        _ = {# call structure_copy #}

-- | Removes the structure at the given index from the current caps.
capsRemoveStructure :: Word
                    -> CapsM ()
capsRemoveStructure idx = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_remove_structure capsPtr $ fromIntegral idx
  where _ = {# call caps_remove_structure #}

-- | Discard all but the first structure from the current caps.
capsTruncate :: CapsM ()
capsTruncate = do
  capsPtr <- askCapsPtr
  CapsM $ liftIO $ gst_caps_truncate capsPtr
  where _ = {# call caps_truncate #}