wibble

wibble

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
#if CUDA_VERSION >= 4000
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x
      Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp   -- Maxwell GM10x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Analysis.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Common device functions
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Analysis.Device
  (
    Compute(..), ComputeMode(..),
    DeviceProperties(..), DeviceResources(..), Allocation(..), PCI(..),
    deviceResources
  )
  where

#include "cbits/stubs.h"

import Data.Int
import Debug.Trace

-- |
-- The compute mode the device is currently in
--
{# enum CUcomputemode as ComputeMode
    { underscoreToCase }
    with prefix="CU_COMPUTEMODE" deriving (Eq, Show) #}

-- |
-- GPU compute capability, major and minor revision number respectively.
--
data Compute = Compute !Int !Int
  deriving Eq

instance Show Compute where
  show (Compute major minor) = show major ++ "." ++ show minor

instance Ord Compute where
  compare (Compute m1 n1) (Compute m2 n2) =
    case compare m1 m2 of
      EQ -> compare n1 n2
      x  -> x

{--
cap :: Int -> Int -> Double
cap a 0 = fromIntegral a
cap a b = let a' = fromIntegral a in
            let b' = fromIntegral b in
            a' + b' / max 10 (10^ ((ceiling . logBase 10) b' :: Int))
--}

-- |
-- The properties of a compute device
--
data DeviceProperties = DeviceProperties
  {
    deviceName                  :: !String,             -- ^ Identifier
    computeCapability           :: !Compute,            -- ^ Supported compute capability
    totalGlobalMem              :: !Int64,              -- ^ Available global memory on the device in bytes
    totalConstMem               :: !Int64,              -- ^ Available constant memory on the device in bytes
    sharedMemPerBlock           :: !Int64,              -- ^ Available shared memory per block in bytes
    regsPerBlock                :: !Int,                -- ^ 32-bit registers per block
    warpSize                    :: !Int,                -- ^ Warp size in threads (SIMD width)
    maxThreadsPerBlock          :: !Int,                -- ^ Max number of threads per block
#if CUDA_VERSION >= 4000
    maxThreadsPerMultiProcessor :: !Int,                -- ^ Max number of threads per multiprocessor
#endif
    maxBlockSize                :: !(Int,Int,Int),      -- ^ Max size of each dimension of a block
    maxGridSize                 :: !(Int,Int,Int),      -- ^ Max size of each dimension of a grid
#if CUDA_VERSION >= 3000
    maxTextureDim1D             :: !Int,                -- ^ Maximum texture dimensions
    maxTextureDim2D             :: !(Int,Int),
    maxTextureDim3D             :: !(Int,Int,Int),
#endif
    clockRate                   :: !Int,                -- ^ Clock frequency in kilohertz
    multiProcessorCount         :: !Int,                -- ^ Number of multiprocessors on the device
    memPitch                    :: !Int64,              -- ^ Max pitch in bytes allowed by memory copies
#if CUDA_VERSION >= 4000
    memBusWidth                 :: !Int,                -- ^ Global memory bus width in bits
    memClockRate                :: !Int,                -- ^ Peak memory clock frequency in kilohertz
#endif
    textureAlignment            :: !Int64,              -- ^ Alignment requirement for textures
    computeMode                 :: !ComputeMode,
    deviceOverlap               :: !Bool,               -- ^ Device can concurrently copy memory and execute a kernel
#if CUDA_VERSION >= 3000
    concurrentKernels           :: !Bool,               -- ^ Device can possibly execute multiple kernels concurrently
    eccEnabled                  :: !Bool,               -- ^ Device supports and has enabled error correction
#endif
#if CUDA_VERSION >= 4000
    asyncEngineCount            :: !Int,                -- ^ Number of asynchronous engines
    cacheMemL2                  :: !Int,                -- ^ Size of the L2 cache in bytes
    tccDriverEnabled            :: !Bool,               -- ^ Whether this is a Tesla device using the TCC driver
    pciInfo                     :: !PCI,                -- ^ PCI device information for the device
#endif
    kernelExecTimeoutEnabled    :: !Bool,               -- ^ Whether there is a runtime limit on kernels
    integrated                  :: !Bool,               -- ^ As opposed to discrete
#if CUDA_VERSION >= 4000
    canMapHostMemory            :: !Bool,               -- ^ Device can use pinned memory
    unifiedAddressing           :: !Bool                -- ^ Device shares a unified address space with the host
#else
    canMapHostMemory            :: !Bool                -- ^ Device can use pinned memory
#endif
  }
  deriving (Show)

data PCI = PCI
  {
    busID       :: !Int,                -- ^ PCI bus ID of the device
    deviceID    :: !Int,                -- ^ PCI device ID
    domainID    :: !Int                 -- ^ PCI domain ID
  }
  deriving (Show)

-- GPU Hardware Resources
--
data Allocation      = Warp | Block
data DeviceResources = DeviceResources
  {
    threadsPerWarp      :: !Int,        -- ^ Warp size
    threadsPerMP        :: !Int,        -- ^ Maximum number of in-flight threads on a multiprocessor
    threadBlocksPerMP   :: !Int,        -- ^ Maximum number of thread blocks resident on a multiprocessor
    warpsPerMP          :: !Int,        -- ^ Maximum number of in-flight warps per multiprocessor
    coresPerMP          :: !Int,        -- ^ Number of SIMD arithmetic units per multiprocessor
    sharedMemPerMP      :: !Int,        -- ^ Total amount of shared memory per multiprocessor (bytes)
    sharedMemAllocUnit  :: !Int,        -- ^ Shared memory allocation unit size (bytes)
    regFileSize         :: !Int,        -- ^ Total number of registers in a multiprocessor
    regAllocUnit        :: !Int,        -- ^ Register allocation unit size
    regAllocWarp        :: !Int,        -- ^ Register allocation granularity for warps
    regPerThread        :: !Int,        -- ^ Maximum number of registers per thread
    allocation          :: !Allocation  -- ^ How multiprocessor resources are divided
  }

-- |
-- Extract some additional hardware resource limitations for a given device.
--
deviceResources :: DeviceProperties -> DeviceResources
deviceResources = resources . computeCapability
  where
    -- This is mostly extracted from tables in the CUDA occupancy calculator.
    --
    resources compute = case compute of
      Compute 1 0 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G80
      Compute 1 1 -> DeviceResources 32  768  8 24   8 16384 512  8192 256 2 124 Block  -- Tesla G8x
      Compute 1 2 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla G9x
      Compute 1 3 -> DeviceResources 32 1024  8 32   8 16384 512 16384 512 2 124 Block  -- Tesla GT200
      Compute 2 0 -> DeviceResources 32 1536  8 48  32 49152 128 32768  64 2  63 Warp   -- Fermi GF100
      Compute 2 1 -> DeviceResources 32 1536  8 48  48 49152 128 32768  64 2  63 Warp   -- Fermi GF10x
      Compute 3 0 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4  63 Warp   -- Kepler GK10x
      Compute 3 5 -> DeviceResources 32 2048 16 64 192 49152 256 65536 256 4 255 Warp   -- Kepler GK11x
      Compute 5 0 -> DeviceResources 32 2048 32 64 128 65536 256 65536 256 4 255 Warp   -- Maxwell GM10x

      -- Something might have gone wrong, or the library just needs to be
      -- updated for the next generation of hardware, in which case we just want
      -- to pick a sensible default and carry on.
      --
      -- This is slightly dodgy as the warning message is coming from pure code.
      -- However, it should be OK because all library functions run in IO, so it
      -- is likely the user code is as well.
      --
      _           -> trace warning $ resources (Compute 3 0)
        where warning = unlines [ "*** Warning: unknown CUDA device compute capability: " ++ show compute
                                , "*** Please submit a bug report at https://github.com/tmcdonell/cuda/issues" ]


slightly more descriptive error strings

slightly more descriptive error strings

Ignore-this: 8eb51c0bbc734e46fef577e25a476909

darcs-hash:20091208065102-9241b-ffc8cb9780e0c71fa610e5e35bd2026c0daf3fd2.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error
  where

import Foreign.CUDA.Internal.C2HS

#include <cuda.h>
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS as Success }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- |
-- Return a descriptive error string associated with a particular error code
-- XXX: yes, not very descriptive...
--
describe :: Status -> String
describe Success                     = "no error"
describe InvalidValue                = "invalid argument"
describe OutOfMemory                 = "out of memory"
describe NotInitialized              = "driver not initialised"
describe Deinitialized               = "driver deinitialised"
describe NoDevice                    = "no CUDA-capable device is available"
describe InvalidDevice               = "invalid device ordinal"
describe InvalidImage                = "invalid kernel image"
describe InvalidContext              = "invalid context handle"
describe ContextAlreadyCurrent       = "context already current"
describe MapFailed                   = "map failed"
describe UnmapFailed                 = "unmap failed"
describe ArrayIsMapped               = "array is mapped"
describe AlreadyMapped               = "already mapped"
describe NoBinaryForGpu              = "no binary available for this GPU"
describe AlreadyAcquired             = "resource already acquired"
describe NotMapped                   = "not mapped"
describe InvalidSource               = "invalid source"
describe FileNotFound                = "file not found"
describe InvalidHandle               = "invalid handle"
describe NotFound                    = "not found"
describe NotReady                    = "device not ready"
describe LaunchFailed                = "unspecified launch failure"
describe LaunchOutOfResources        = "too many resources requested for launch"
describe LaunchTimeout               = "the launch timed out and was terminated"
describe LaunchIncompatibleTexturing = "launch with incompatible texturing"
describe Unknown                     = "unknown error"

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
resultIfOk :: (Status, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (describe status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
nothingIfOk :: Status -> Maybe String
nothingIfOk = nothingIf (== Success) describe

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error
  where

import Foreign.CUDA.Internal.C2HS

#include <cuda.h>
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS as Success }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- |
-- Return a descriptive error string associated with a particular error code
-- XXX: yes, not very descriptive...
--
describe :: Status -> String
describe = show

-- |
-- Return the results of a function on successful execution, otherwise return
-- the error string associated with the return code
--
resultIfOk :: (Status, a) -> Either String a
resultIfOk (status,result) =
    case status of
        Success -> Right result
        _       -> Left (describe status)

-- |
-- Return the error string associated with an unsuccessful return code,
-- otherwise Nothing
--
nothingIfOk :: Status -> Maybe String
nothingIfOk = nothingIf (== Success) describe


Fix documenation to Editable.

Fix documenation to Editable.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Interface Editable
--
--  Author : Axel Simon, Duncan Coutts
--
--  Created: 30 July 2004
--
--  Copyright (C) 1999-2005 Axel Simon, Duncan Coutts
--
--  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)
--
-- Interface for text-editing widgets
--
module Graphics.UI.Gtk.Entry.Editable (
-- * Detail
--
-- | The 'Editable' interface is an interface which should be implemented by
-- text editing widgets, such as 'Entry'.
-- It contains functions for generically manipulating an editable
-- widget, a large number of action signals used for key bindings, and several
-- signals that an application can connect to to modify the behavior of a
-- widget.
--

-- * Class Hierarchy
-- |
-- @
-- |  GInterface
-- |   +----Editable
-- @

-- * Types
  Editable,
  EditableClass,
  castToEditable, gTypeEditable,
  toEditable,

-- * Methods
  editableSelectRegion,
  editableGetSelectionBounds,
  editableInsertText,
  editableDeleteText,
  editableGetChars,
  editableCutClipboard,
  editableCopyClipboard,
  editablePasteClipboard,
  editableDeleteSelection,
  editableSetEditable,
  editableGetEditable,
  editableSetPosition,
  editableGetPosition,

-- * Attributes
  editablePosition,
  editableEditable,

-- * Signals
  onEditableChanged,
  afterEditableChanged,
  onDeleteText,
  afterDeleteText,
  stopDeleteText,
  onInsertText,
  afterInsertText,
  stopInsertText
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

{# context lib="gtk" prefix="gtk" #}

--------------------
-- Methods

-- | Selects a region of text. The characters that are selected are those
-- characters at positions from @startPos@ up to, but not including @endPos@.
-- If @endPos@ is negative, then the the characters selected will be those
-- characters from @startPos@ to the end of the text.
--
-- Calling this function with @start@=1 and @end@=4 it will mark \"ask\" in
-- the string \"Haskell\".
--
editableSelectRegion :: EditableClass self => self
 -> Int   -- ^ @start@ - the starting position.
 -> Int   -- ^ @end@ - the end position.
 -> IO ()
editableSelectRegion self start end =
  {# call editable_select_region #}
    (toEditable self)
    (fromIntegral start)
    (fromIntegral end)

-- | Gets the current selection bounds, if there is a selection.
--
editableGetSelectionBounds :: EditableClass self => self
 -> IO (Int,Int) -- ^ @(start, end)@ - the starting and end positions. This
                 -- pair is not ordered. The @end@ index represents the
                 -- position of the cursor. The @start@ index is the other end
                 -- of the selection. If both numbers are equal there is in
                 -- fact no selection.
editableGetSelectionBounds self =
  alloca $ \startPtr ->
  alloca $ \endPtr -> do
  {# call unsafe editable_get_selection_bounds #}
    (toEditable self)
    startPtr
    endPtr
  start <- liftM fromIntegral $ peek startPtr
  end   <- liftM fromIntegral $ peek endPtr
  return (start,end)

-- | Inserts text at a given position.
--
editableInsertText :: EditableClass self => self
 -> String -- ^ @newText@ - the text to insert.
 -> Int    -- ^ @position@ - the position at which to insert the text.
 -> IO Int -- ^ returns the position after the newly inserted text.
editableInsertText self newText position =
  with (fromIntegral position) $ \positionPtr ->
  withUTFStringLen newText $ \(newTextPtr, newTextLength) -> do
  {# call editable_insert_text #}
    (toEditable self)
    newTextPtr
    (fromIntegral newTextLength)
    positionPtr
  position <- peek positionPtr
  return (fromIntegral position)

-- | Deletes a sequence of characters. The characters that are deleted are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters deleted will be
-- those characters from @startPos@ to the end of the text.
--
editableDeleteText :: EditableClass self => self
 -> Int   -- ^ @startPos@ - the starting position.
 -> Int   -- ^ @endPos@ - the end position.
 -> IO ()
editableDeleteText self startPos endPos =
  {# call editable_delete_text #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)

-- | Retrieves a sequence of characters. The characters that are retrieved are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters retrieved will be
-- those characters from @startPos@ to the end of the text.
--
editableGetChars :: EditableClass self => self
 -> Int       -- ^ @startPos@ - the starting position.
 -> Int       -- ^ @endPos@ - the end position.
 -> IO String -- ^ returns the characters in the indicated region.
editableGetChars self startPos endPos =
  {# call unsafe editable_get_chars #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)
  >>= readUTFString

-- | Causes the characters in the current selection to be copied to the
-- clipboard and then deleted from the widget.
--
editableCutClipboard :: EditableClass self => self -> IO ()
editableCutClipboard self =
  {# call editable_cut_clipboard #}
    (toEditable self)

-- | Causes the characters in the current selection to be copied to the
-- clipboard.
--
editableCopyClipboard :: EditableClass self => self -> IO ()
editableCopyClipboard self =
  {# call editable_copy_clipboard #}
    (toEditable self)

-- | Causes the contents of the clipboard to be pasted into the given widget
-- at the current cursor position.
--
editablePasteClipboard :: EditableClass self => self -> IO ()
editablePasteClipboard self =
  {# call editable_paste_clipboard #}
    (toEditable self)

-- | Deletes the current contents of the widgets selection and disclaims the
-- selection.
--
editableDeleteSelection :: EditableClass self => self -> IO ()
editableDeleteSelection self =
  {# call editable_delete_selection #}
    (toEditable self)

-- | Sets the cursor position.
--
editableSetPosition :: EditableClass self => self
 -> Int   -- ^ @position@ - the position of the cursor. The cursor is
          -- displayed before the character with the given (base 0) index in
          -- the widget. The value must be less than or equal to the number of
          -- characters in the widget. A value of -1 indicates that the
          -- position should be set after the last character in the entry.
 -> IO ()
editableSetPosition self position =
  {# call editable_set_position #}
    (toEditable self)
    (fromIntegral position)

-- | Retrieves the current cursor position.
--
editableGetPosition :: EditableClass self => self
 -> IO Int -- ^ returns the position of the cursor. The cursor is displayed
           -- before the character with the given (base 0) index in the widget.
           -- The value will be less than or equal to the number of characters
           -- in the widget. Note that this position is in characters, not in
           -- bytes.
editableGetPosition self =
  liftM fromIntegral $
  {# call unsafe editable_get_position #}
    (toEditable self)

-- | Determines if the user can edit the text in the editable widget or not.
--
editableSetEditable :: EditableClass self => self
 -> Bool  -- ^ @isEditable@ - @True@ if the user is allowed to edit the text
          -- in the widget.
 -> IO ()
editableSetEditable self isEditable =
  {# call editable_set_editable #}
    (toEditable self)
    (fromBool isEditable)

-- | Retrieves whether the text is editable. See 'editableSetEditable'.
--
editableGetEditable :: EditableClass self => self -> IO Bool
editableGetEditable self =
  liftM toBool $
  {# call editable_get_editable #}
    (toEditable self)

--------------------
-- Attributes

-- | \'position\' property. See 'editableGetPosition' and
-- 'editableSetPosition'
--
editablePosition :: EditableClass self => Attr self Int
editablePosition = newAttr
  editableGetPosition
  editableSetPosition

-- | \'editable\' property. See 'editableGetEditable' and
-- 'editableSetEditable'
--
editableEditable :: EditableClass self => Attr self Bool
editableEditable = newAttr
  editableGetEditable
  editableSetEditable

--------------------
-- Signals

-- | The 'onEditableChanged' signal is emitted at the end of a single
-- user-visible operation on the contents of the 'Editable'.
--
-- * For inctance, a paste operation that replaces the contents of the
--   selection will cause only one signal emission (even though it is
--   implemented by first deleting the selection, then inserting the new
--   content, and may cause multiple 'onEditableInserText' signals to be
--   emitted).
--
onEditableChanged, afterEditableChanged :: EditableClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEditableChanged = connect_NONE__NONE "changed" False
afterEditableChanged = connect_NONE__NONE "changed" True

-- | Emitted when a piece of text is deleted from the 'Editable' widget.
--
-- * See 'onInsertText' for information on how to use this signal.
--
onDeleteText, afterDeleteText :: EditableClass self => self
 -> (Int -> Int -> IO ()) -- ^ @(\startPos endPos -> ...)@
 -> IO (ConnectId self)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True

-- | Stop the current signal that deletes text.
stopDeleteText :: EditableClass self => ConnectId self -> IO ()
stopDeleteText (ConnectId _ obj) =
  signalStopEmission obj "delete_text"

-- | Emitted when a piece of text is inserted into the 'Editable' widget.
--
-- * The connected signal receives the text that is inserted, together with
--   the position in the entry widget. The return value should be the position
--   in the entry widget that lies past the recently inserted text (i.e.
--   you should return the given position plus the length of the string).
--
-- * To modify the text that the user inserts, you need to connect to this
--   signal, modify the text the way you want and then call
--   'editableInsertText'. To avoid that this signal handler is called
--   recursively, you need to temporarily block it using
--   'signalBlock'. After the default signal
--   handler has inserted your modified text, it is important that you
--   prevent the default handler from being executed again when this signal
--   handler returns. To stop the current signal, use 'stopInsertText'.
--   The following code is an example of how to turn all input into uppercase:
--
--   > idRef <- newIORef undefined
--   > id <- onInsertText entry $ \str pos -> do
--   >   id <- readIORef idRef
--   >   signalBlock id
--   >   pos' <- editableInsertText entry (map toUpper str) pos
--   >   signalUnblock id
--   >   stopInsertText id
--   >   return pos'
--   > writeIORef idRef id
--
--   Note that the 'afterInsertText' function is not very useful, except to
--   track editing actions.
--
onInsertText, afterInsertText :: EditableClass self => self
 -> (String -> Int -> IO Int)
 -> IO (ConnectId self)
onInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" False obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )
afterInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" True obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )

-- | Stop the current signal that inserts text.
stopInsertText :: EditableClass self => ConnectId self -> IO ()
stopInsertText (ConnectId _ obj) =
  signalStopEmission obj "insert_text"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Interface Editable
--
--  Author : Axel Simon, Duncan Coutts
--
--  Created: 30 July 2004
--
--  Copyright (C) 1999-2005 Axel Simon, Duncan Coutts
--
--  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)
--
-- Interface for text-editing widgets
--
module Graphics.UI.Gtk.Entry.Editable (
-- * Detail
--
-- | The 'Editable' interface is an interface which should be implemented by
-- text editing widgets, such as 'Entry'.
-- It contains functions for generically manipulating an editable
-- widget, a large number of action signals used for key bindings, and several
-- signals that an application can connect to to modify the behavior of a
-- widget.
--

-- * Class Hierarchy
-- |
-- @
-- |  GInterface
-- |   +----Editable
-- @

-- * Types
  Editable,
  EditableClass,
  castToEditable, gTypeEditable,
  toEditable,

-- * Methods
  editableSelectRegion,
  editableGetSelectionBounds,
  editableInsertText,
  editableDeleteText,
  editableGetChars,
  editableCutClipboard,
  editableCopyClipboard,
  editablePasteClipboard,
  editableDeleteSelection,
  editableSetEditable,
  editableGetEditable,
  editableSetPosition,
  editableGetPosition,

-- * Attributes
  editablePosition,
  editableEditable,

-- * Signals
  onEditableChanged,
  afterEditableChanged,
  onDeleteText,
  afterDeleteText,
  stopDeleteText,
  onInsertText,
  afterInsertText,
  stopInsertText
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Attributes
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}

{# context lib="gtk" prefix="gtk" #}

--------------------
-- Methods

-- | Selects a region of text. The characters that are selected are those
-- characters at positions from @startPos@ up to, but not including @endPos@.
-- If @endPos@ is negative, then the the characters selected will be those
-- characters from @startPos@ to the end of the text.
--
-- Calling this function with @start@=1 and @end@=4 it will mark \"ask\" in
-- the string \"Haskell\".
--
editableSelectRegion :: EditableClass self => self
 -> Int   -- ^ @start@ - the starting position.
 -> Int   -- ^ @end@ - the end position.
 -> IO ()
editableSelectRegion self start end =
  {# call editable_select_region #}
    (toEditable self)
    (fromIntegral start)
    (fromIntegral end)

-- | Gets the current selection bounds, if there is a selection.
--
editableGetSelectionBounds :: EditableClass self => self
 -> IO (Int,Int) -- ^ @(start, end)@ - the starting and end positions. This
                 -- pair is not ordered. The @end@ index represents the
                 -- position of the cursor. The @start@ index is the other end
                 -- of the selection. If both numbers are equal there is in
                 -- fact no selection.
editableGetSelectionBounds self =
  alloca $ \startPtr ->
  alloca $ \endPtr -> do
  {# call unsafe editable_get_selection_bounds #}
    (toEditable self)
    startPtr
    endPtr
  start <- liftM fromIntegral $ peek startPtr
  end   <- liftM fromIntegral $ peek endPtr
  return (start,end)

-- | Inserts text at a given position.
--
editableInsertText :: EditableClass self => self
 -> String -- ^ @newText@ - the text to insert.
 -> Int    -- ^ @position@ - the position at which to insert the text.
 -> IO Int -- ^ returns the position after the newly inserted text.
editableInsertText self newText position =
  with (fromIntegral position) $ \positionPtr ->
  withUTFStringLen newText $ \(newTextPtr, newTextLength) -> do
  {# call editable_insert_text #}
    (toEditable self)
    newTextPtr
    (fromIntegral newTextLength)
    positionPtr
  position <- peek positionPtr
  return (fromIntegral position)

-- | Deletes a sequence of characters. The characters that are deleted are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters deleted will be
-- those characters from @startPos@ to the end of the text.
--
editableDeleteText :: EditableClass self => self
 -> Int   -- ^ @startPos@ - the starting position.
 -> Int   -- ^ @endPos@ - the end position.
 -> IO ()
editableDeleteText self startPos endPos =
  {# call editable_delete_text #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)

-- | Retrieves a sequence of characters. The characters that are retrieved are
-- those characters at positions from @startPos@ up to, but not including
-- @endPos@. If @endPos@ is negative, then the the characters retrieved will be
-- those characters from @startPos@ to the end of the text.
--
editableGetChars :: EditableClass self => self
 -> Int       -- ^ @startPos@ - the starting position.
 -> Int       -- ^ @endPos@ - the end position.
 -> IO String -- ^ returns the characters in the indicated region.
editableGetChars self startPos endPos =
  {# call unsafe editable_get_chars #}
    (toEditable self)
    (fromIntegral startPos)
    (fromIntegral endPos)
  >>= readUTFString

-- | Causes the characters in the current selection to be copied to the
-- clipboard and then deleted from the widget.
--
editableCutClipboard :: EditableClass self => self -> IO ()
editableCutClipboard self =
  {# call editable_cut_clipboard #}
    (toEditable self)

-- | Causes the characters in the current selection to be copied to the
-- clipboard.
--
editableCopyClipboard :: EditableClass self => self -> IO ()
editableCopyClipboard self =
  {# call editable_copy_clipboard #}
    (toEditable self)

-- | Causes the contents of the clipboard to be pasted into the given widget
-- at the current cursor position.
--
editablePasteClipboard :: EditableClass self => self -> IO ()
editablePasteClipboard self =
  {# call editable_paste_clipboard #}
    (toEditable self)

-- | Deletes the current contents of the widgets selection and disclaims the
-- selection.
--
editableDeleteSelection :: EditableClass self => self -> IO ()
editableDeleteSelection self =
  {# call editable_delete_selection #}
    (toEditable self)

-- | Sets the cursor position.
--
editableSetPosition :: EditableClass self => self
 -> Int   -- ^ @position@ - the position of the cursor. The cursor is
          -- displayed before the character with the given (base 0) index in
          -- the widget. The value must be less than or equal to the number of
          -- characters in the widget. A value of -1 indicates that the
          -- position should be set after the last character in the entry.
 -> IO ()
editableSetPosition self position =
  {# call editable_set_position #}
    (toEditable self)
    (fromIntegral position)

-- | Retrieves the current cursor position.
--
editableGetPosition :: EditableClass self => self
 -> IO Int -- ^ returns the position of the cursor. The cursor is displayed
           -- before the character with the given (base 0) index in the widget.
           -- The value will be less than or equal to the number of characters
           -- in the widget. Note that this position is in characters, not in
           -- bytes.
editableGetPosition self =
  liftM fromIntegral $
  {# call unsafe editable_get_position #}
    (toEditable self)

-- | Determines if the user can edit the text in the editable widget or not.
--
editableSetEditable :: EditableClass self => self
 -> Bool  -- ^ @isEditable@ - @True@ if the user is allowed to edit the text
          -- in the widget.
 -> IO ()
editableSetEditable self isEditable =
  {# call editable_set_editable #}
    (toEditable self)
    (fromBool isEditable)

-- | Retrieves whether the text is editable. See 'editableSetEditable'.
--
editableGetEditable :: EditableClass self => self -> IO Bool
editableGetEditable self =
  liftM toBool $
  {# call editable_get_editable #}
    (toEditable self)

--------------------
-- Attributes

-- | \'position\' property. See 'editableGetPosition' and
-- 'editableSetPosition'
--
editablePosition :: EditableClass self => Attr self Int
editablePosition = newAttr
  editableGetPosition
  editableSetPosition

-- | \'editable\' property. See 'editableGetEditable' and
-- 'editableSetEditable'
--
editableEditable :: EditableClass self => Attr self Bool
editableEditable = newAttr
  editableGetEditable
  editableSetEditable

--------------------
-- Signals

-- | Emitted when the settings of the 'Editable' widget changes.
--
onEditableChanged, afterEditableChanged :: EditableClass ec => ec -> IO () ->
                                     IO (ConnectId ec)
onEditableChanged = connect_NONE__NONE "changed" False
afterEditableChanged = connect_NONE__NONE "changed" True

-- | Emitted when a piece of text is deleted from the 'Editable' widget.
--
-- * See 'onInsertText' for information on how to use this signal.
--
onDeleteText, afterDeleteText :: EditableClass self => self
 -> (Int -> Int -> IO ()) -- ^ @(\startPos endPos -> ...)@
 -> IO (ConnectId self)
onDeleteText = connect_INT_INT__NONE "delete_text" False
afterDeleteText = connect_INT_INT__NONE "delete_text" True

-- | Stop the current signal that deletes text.
stopDeleteText :: EditableClass self => ConnectId self -> IO ()
stopDeleteText (ConnectId _ obj) =
  signalStopEmission obj "delete_text"

-- | Emitted when a piece of text is inserted into the 'Editable' widget.
--
-- * The connected signal receives the text that is inserted, together with
--   the position in the entry widget. The return value should be the position
--   in the entry widget that lies past the recently inserted text (i.e.
--   you should return the given position plus the length of the string).
--
-- * To modify the text that the user inserts, you need to connect to this
--   signal, modify the text the way you want and then call
--   'editableInsertText'. To avoid that this signal handler is called
--   recursively, you need to temporarily block it using
--   'signalBlock'. After the default signal
--   handler has inserted your modified text, it is important that you
--   prevent the default handler from being executed again when this signal
--   handler returns. To stop the current signal, use 'stopInsertText'.
--   The following code is an example of how to turn all input into uppercase:
--
--   > idRef <- newIORef undefined
--   > id <- onInsertText entry $ \str pos -> do
--   >   id <- readIORef idRef
--   >   signalBlock id
--   >   pos' <- editableInsertText entry (map toUpper str) pos
--   >   signalUnblock id
--   >   stopInsertText id
--   >   return pos'
--   > writeIORef idRef id
--
--   Note that the 'afterInsertText' function is not very useful, except to
--   track editing actions.
--
onInsertText, afterInsertText :: EditableClass self => self
 -> (String -> Int -> IO Int)
 -> IO (ConnectId self)
onInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" False obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )
afterInsertText obj handler =
  connect_PTR_INT_PTR__NONE "insert_text" True obj
  (\strPtr strLen posPtr -> do
    str <- if strLen<0 then peekUTFString strPtr
           else peekUTFStringLen (strPtr, strLen)
    pos <- peek (posPtr :: Ptr {#type gint#})
    pos' <- handler str (fromIntegral pos)
    poke (posPtr :: Ptr {#type gint#}) (fromIntegral pos')
  )

-- | Stop the current signal that inserts text.
stopInsertText :: EditableClass self => ConnectId self -> IO ()
stopInsertText (ConnectId _ obj) =
  signalStopEmission obj "insert_text"


gstreamer: document M.S.G.Core.Clock

gstreamer: document M.S.G.Core.Clock

--  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)
--
--  Abstract class of global clocks.
module Media.Streaming.GStreamer.Core.Clock (

-- * Detail
  -- | GStreamer uses a global clock to synchronize the plugins in a
  --   pipeline. Different clock implementations are possible by
  --   implementing this abstract base class.
  --
  --   The 'Clock' returns a monotonically increasing time with the
  --   method 'clockGetTime'. Its accuracy and base time depend
  --   on the specific clock implementation but time is always
  --   expressed in nanoseconds. Since the baseline of the clock is
  --   undefined, the clock time returned is not meaningful in itself,
  --   what matters are the deltas between two clock times. The time
  --   returned by a clock is called the absolute time.
  --
  --   The pipeline uses the clock to calculate the stream
  --   time. Usually all renderers synchronize to the global clock
  --   using the buffer timestamps, the newsegment events and the
  --   element's base time, see GstPipeline.
  --
  --   A clock implementation can support periodic and single shot
  --   clock notifications both synchronous and asynchronous.
  --
  --   One first needs to create a 'ClockID' for the periodic or
  --   single shot notification using 'clockNewSingleShotID' or
  --   'clockNewPeriodicID'.
  --
  --   To perform a blocking wait for the specific time of the
  --   'ClockID' use 'clockIDWait'. This calls can be interrupted with
  --   the 'clockIDUnschedule' call. If the blocking wait is
  --   unscheduled a return value of 'ClockUnscheduled' is returned.
  --
  --   Periodic callbacks scheduled async will be repeadedly called
  --   automatically until it is unscheduled. To schedule a sync
  --   periodic callback, 'clockIDWait' should be called repeatedly.
  --
  --   The async callbacks can happen from any thread, either provided
  --   by the core or from a streaming thread. The application should
  --   be prepared for this.
  --
  --   A 'ClockID' that has been unscheduled cannot be used again for
  --   any wait operation; a new 'ClockID' should be created.
  --
  --   It is possible to perform a blocking wait on the same 'ClockID'
  --   from multiple threads. However, registering the same 'ClockID'
  --   for multiple async notifications is not possible, the callback
  --   will only be called for the thread registering the entry last.
  --
  --   These clock operations do not operate on the stream time, so
  --   the callbacks will also occur when not in the playing state as
  --   if the clock just keeps on running. Some clocks however do not
  --   progress when the element that provided the clock is not
  --   playing.
  --
  --   When a clock has the 'ClockFlagCanSetMaster' flag set, it can
  --   be slaved to another 'Clock' with 'clockSetMaster'. The clock
  --   will then automatically be synchronized to this master clock by
  --   repeatedly sampling the master clock and the slave clock and
  --   recalibrating the slave clock with 'clockSetCalibration'. This
  --   feature is mostly useful for plugins that have an internal
  --   clock but must operate with another clock selected by the
  --   GstPipeline. They can track the offset and rate difference of
  --   their internal clock relative to the master clock by using the
  --   'clockGetCalibration' function.
  --
  --   The master\/slave synchronisation can be tuned with the
  --   the 'clockTimeout', 'clockWindowSize' and 'clockWindowThreshold' properties.
  --   The 'clockTimeout' property defines the interval to
  --   sample the master clock and run the calibration
  --   functions. 'clockWindowSize' defines the number of samples to
  --   use when calibrating and 'clockWindowThreshold' defines the
  --   minimum number of samples before the calibration is performed.

-- * Types
  Clock,
  ClockClass,
  castToClock,
  toClock,

  -- | A time value measured in nanoseconds.
  ClockTime,

  -- | The 'ClockTime' value representing an invalid time.
  clockTimeNone,
  clockTimeIsValid,

  -- | The 'ClockTime' value representing 1 second, i.e. 1e9.
  second,
  -- | The 'ClockTime' value representing 1 millisecond, i.e. 1e6.
  msecond,
  -- | The 'ClockTime' value representing 1 microsecond, i.e. 1e3.
  usecond,
  -- | The 'ClockTime' value representing 1 nanosecond, i.e. 1.
  nsecond,
  -- | A value holding the difference between two 'ClockTime's.
  ClockTimeDiff,
  -- | An opaque identifier for a timer event.
  ClockID,
  -- | An enumeration type returned by 'clockIDWait'.
  ClockReturn(..),
  -- | The flags a 'Clock' may have.
  ClockFlags(..),
  clockGetFlags,
  clockSetFlags,
  clockUnsetFlags,

-- * Clock Operations
  clockAddObservation,
  clockSetMaster,
  clockGetMaster,
  clockSetResolution,
  clockGetResolution,
  clockGetTime,
  clockNewSingleShotID,
  clockNewPeriodicID,
  clockGetInternalTime,
  clockGetCalibration,
  clockSetCalibration,
  clockIDGetTime,
  clockIDWait,
  clockIDUnschedule,

-- * Clock Properties
  clockTimeout,
  clockWindowSize,
  clockWindowThreshold

  ) where

import Data.Ratio ( Ratio
                  , (%)
                  , numerator
                  , denominator )
import Control.Monad ( liftM
                     , liftM4)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.FFI
import System.Glib.Attributes ( Attr
                              , newAttr )
import System.Glib.Properties

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

-- | Gets the flags set on the clock.
clockGetFlags :: ClockClass clockT
              => clockT          -- ^ @clock@
              -> IO [ClockFlags] -- ^ the flags currently set on the clock
clockGetFlags = mkObjectGetFlags

-- | Sets the given flags on the clock.
clockSetFlags :: ClockClass clockT
              => clockT       -- ^ @clock@
              -> [ClockFlags] -- ^ @flags@ - the flags to be set
              -> IO ()
clockSetFlags = mkObjectSetFlags

-- | Unsets the given flags on the clock.
clockUnsetFlags :: ClockClass clockT
                => clockT       -- ^ @clock@
                -> [ClockFlags] -- ^ @flags@ - the flags to be unset
                -> IO ()
clockUnsetFlags = mkObjectUnsetFlags

-- | Returns 'True' if the given 'ClockTime' is valid, and 'False'
--   otherwise.
clockTimeIsValid :: ClockTime -- ^ @clockTime@
                 -> Bool      -- ^ 'True' if @clockTime@ is valid, 'False' otherwise
clockTimeIsValid = (/= clockTimeNone)

-- | The time master of the master clock and the time slave of the
--   slave clock are added to the list of observations. If enough
--   observations are available, a linear regression algorithm is run
--   on the observations and clock is recalibrated.
--
--   If a calibration is performed, the correlation coefficient of the
--   interpolation will be returned. A value of 1.0 means the clocks
--   are in perfect sync. This value can be used to control the
--   sampling frequency of the master and slave clocks.
clockAddObservation :: ClockClass clock
                    => clock
                    -> ClockTime
                    -> ClockTime
                    -> IO (Maybe Double)
clockAddObservation clock slave master =
    alloca $ \rSquaredPtr ->
        do success <- {# call clock_add_observation #} (toClock clock)
                                                       (fromIntegral slave)
                                                       (fromIntegral master)
                                                       rSquaredPtr
           if toBool success
               then liftM (Just . realToFrac) $ peek rSquaredPtr
               else return Nothing

-- | Set @master@ as the master clock for @clock@. The @clock@ will
--   automatically be calibrated so that 'clockGetTime' reports the
--   same time as the @master@ clock.
--
--   A clock provider that slaves its clock to a master can get the
--   current calibration values with 'clockGetCalibration'.
--
--   The @master@ clock can be 'Nothing' in which case @clock@ will
--   not be slaved any longer. It will, however, continue to report
--   its time adjusted using the last configured rate and time
--   offsets.
--
--   Note that if @clock@ does not have the 'ClockFlagCanSetMaster'
--   flag set, this function will not succeed and return 'False'.
clockSetMaster :: (ClockClass clock, ClockClass master)
               => clock        -- ^ @clock@
               -> Maybe master -- ^ @master@
               -> IO Bool      -- ^ 'True' if @clock@ is capable of
                               --   being slaved to the @master@ clock, otherwise 'False'
clockSetMaster clock master =
    withObject (toClock clock) $ \clockPtr ->
        maybeWith withObject (liftM toClock $ master) $ \masterPtr ->
            liftM toBool $ gst_clock_set_master clockPtr masterPtr
    where
      _ = {# call clock_set_master #}

-- | Return the master that @clock@ is slaved to, or 'Nothing' if
--   @clock@ is not slaved.
clockGetMaster :: ClockClass clock
               => clock            -- ^ @clock@
               -> IO (Maybe Clock) -- ^ the master that @clock@ is slaved to, or 'Nothing'
clockGetMaster clock =
    {# call clock_get_master #} (toClock clock) >>= maybePeek takeObject

-- | Set the resolution of @clock@. Some clocks have the possibility
--   to operate with different resolution at the expense of more
--   resource usage. There is normally no need to change the default
--   resolution of a clock. The resolution of a clock can only be
--   changed if the clock has the 'ClockFlagCanSetResolution' flag
--   set.
clockSetResolution :: ClockClass clock
                   => clock
                   -> ClockTime
                   -> IO ClockTime
clockSetResolution clock resolution =
    liftM fromIntegral $
        {# call clock_set_resolution #} (toClock clock)
                                        (fromIntegral resolution)

-- | Get the resolution of the @clock@. The resolution of the clock is
--   the granularity of the values returned by 'clockGetTime'.
clockGetResolution :: ClockClass clock
                   => clock        -- ^ @clock@
                   -> IO ClockTime -- ^ the resolution currently set in @clock@
clockGetResolution clock =
    liftM fromIntegral $
        {# call clock_get_resolution #} (toClock clock)

-- | Gets the current time of @clock@. The time is always
--   monotonically increasing and adjusted according to the current
--   offset and rate.
clockGetTime :: ClockClass clock
             => clock        -- ^ @clock@
             -> IO ClockTime -- ^ the current time in @clock@
clockGetTime clock =
    liftM fromIntegral $
        {# call clock_get_time #} (toClock clock)

-- | Get a 'ClockID' from @clock@ to trigger a single shot
--   notification at the requested time.
clockNewSingleShotID :: ClockClass clock
                     => clock      -- ^ @clock@
                     -> ClockTime  -- ^ @clockTime@
                     -> IO ClockID -- ^ a single shot notification id triggered at @clockTime@
clockNewSingleShotID clock time =
    {# call clock_new_single_shot_id #} (toClock clock)
                                        (fromIntegral time) >>=
        takeClockID . castPtr

-- | Get a 'ClockID' from @clock@ to trigger periodic
--   notifications. The notifications will start at time @startTime@
--   and then be fired at each @interval@ after.
clockNewPeriodicID :: ClockClass clock
                   => clock      -- ^ @clock@
                   -> ClockTime  -- ^ @startTime@
                   -> ClockTime  -- ^ @interval@
                   -> IO ClockID -- ^ a periodic notification id
clockNewPeriodicID clock startTime interval =
    {# call clock_new_periodic_id #} (toClock clock)
                                     (fromIntegral startTime)
                                     (fromIntegral interval) >>=
        takeClockID . castPtr

-- | Gets the current internal time of @clock@. The time is
--   returned unadjusted in the offset and rate.
clockGetInternalTime :: ClockClass clock
                     => clock        -- ^ @clock@
                     -> IO ClockTime -- ^ the clock's internal time value
clockGetInternalTime clock =
    liftM fromIntegral $
        {# call clock_get_internal_time #} (toClock clock)

-- | Gets the internal rate and reference time of @clock@. See
--   'clockSetCalibration' for more information.
clockGetCalibration :: ClockClass clock
                    => clock -- ^ @clock@
                    -> IO (ClockTime, ClockTime, Ratio ClockTime)
                       -- ^ the clock's internal time, external (adjusted) time, and skew rate
clockGetCalibration clock =
    alloca $ \internalPtr ->
        alloca $ \externalPtr ->
            alloca $ \rateNumPtr ->
                alloca $ \rateDenomPtr ->
                    do {# call clock_get_calibration #} (toClock clock)
                                                        internalPtr
                                                        externalPtr
                                                        rateNumPtr
                                                        rateDenomPtr
                       liftM4 (\a b c d ->
                               (fromIntegral a,
                                fromIntegral b,
                                fromIntegral c % fromIntegral d))
                              (peek internalPtr)
                              (peek externalPtr)
                              (peek rateNumPtr)
                              (peek rateDenomPtr)

-- | Adjusts the rate and time of clock. A rate of @1 % 1@ is the
--   normal speed of the clock. Larger values make the clock go
--   faster.
--
--   The parameters @internal@ and @external@ specifying that
--   'clockGetTime' should have returned @external@ when the clock had
--   internal time @internal@. The parameter @internal@ should not be
--   in the future; that is, it should be less than the value returned
--   by 'clockGetInternalTime' when this function is called.
--
--   Subsequent calls to 'clockGetTime' will return clock times
--   computed as follows:
--
--   > (clock_internal - internal) * rate + external
--
--   Note that 'clockGetTime' always returns increasing values, so if
--   the clock is moved backwards, 'clockGetTime' will report the
--   previous value until the clock catches up.
clockSetCalibration :: ClockClass clock
                    => clock           -- ^ @clock@
                    -> ClockTime       -- ^ @internal@
                    -> ClockTime       -- ^ @external@
                    -> Ratio ClockTime -- ^ @rate@
                    -> IO ()
clockSetCalibration clock internal external rate =
    {# call clock_set_calibration #} (toClock clock)
                                     (fromIntegral internal)
                                     (fromIntegral external)
                                     (fromIntegral $ numerator rate)
                                     (fromIntegral $ denominator rate)

-- | Get the time of @clockID@.
clockIDGetTime :: ClockID      -- ^ @clockID@
               -> IO ClockTime
clockIDGetTime clockID =
    liftM fromIntegral $ withClockID clockID $
        {# call clock_id_get_time #} . castPtr

-- | Perform a blocking wait on @clockID@. The parameter @clockID@
--   should have been created with 'clockNewSingleShotID' or
--   'clockNewPeriodicID', and should not been unscheduled with a call
--   to 'clockIDUnschedule'.
--
--   If second value in the returned pair is not 'Nothing', it will
--   contain the difference against the clock and the time of
--   @clockID@ when this method was called. Positive values indicate
--   how late @clockID@ was relative to the clock. Negative values
--   indicate how much time was spend waiting on the clock before the
--   function returned.
clockIDWait :: ClockID -- ^ @clockID@
            -> IO (ClockReturn, Maybe ClockTimeDiff)
clockIDWait clockID =
    alloca $ \jitterPtr ->
        do result <- liftM cToEnum $ withClockID clockID $ \clockIDPtr ->
                         {# call clock_id_wait #} (castPtr clockIDPtr) jitterPtr
           jitter <- let peekJitter = liftM (Just . fromIntegral) $ peek jitterPtr
                     in case result of
                          ClockOk -> peekJitter
                          ClockEarly -> peekJitter
                          _ -> return Nothing
           return (result, jitter)

-- | Cancel an outstanding request with @clockID@. After this call,
--   @clockID@ cannot be used anymore to recieve notifications; you
--   must create a new 'ClockID'.
clockIDUnschedule :: ClockID -- ^ @clockID@
                  -> IO ()
clockIDUnschedule clockID =
    withClockID clockID $ {# call clock_id_unschedule #} . castPtr

clockTimeout :: ClockClass clockT
             => Attr clockT ClockTime
clockTimeout = newAttr
    (objectGetPropertyUInt64 "timeout")
    (objectSetPropertyUInt64 "timeout")

clockWindowSize :: ClockClass clockT
                => Attr clockT Int
clockWindowSize =
    newAttrFromIntProperty "window-size"

clockWindowThreshold :: ClockClass clockT
                     => Attr clockT Int
clockWindowThreshold =
    newAttrFromIntProperty "window-threshold"

--  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)
module Media.Streaming.GStreamer.Core.Clock (

  Clock,
  ClockClass,
  castToClock,
  toClock,

  ClockTime,
  clockTimeNone,
  clockTimeIsValid,
  second,
  msecond,
  usecond,
  nsecond,

  ClockTimeDiff,
  ClockReturn(..),
  ClockID,

  ClockFlags(..),
  clockGetFlags,
  clockSetFlags,
  clockUnsetFlags,

  clockAddObservation,
  clockSetMaster,
  clockGetMaster,
  clockSetResolution,
  clockGetResolution,
  clockGetTime,
  clockNewSingleShotID,
  clockNewPeriodicID,
  clockGetInternalTime,
  clockGetCalibration,
  clockSetCalibration,
  clockIDGetTime,
  clockIDWait,
  clockIDUnschedule,

  clockTimeout,
  clockWindowSize,
  clockWindowThreshold

  ) where

import Data.Ratio ( Ratio
                  , (%)
                  , numerator
                  , denominator )
import Control.Monad (liftM, liftM4)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.FFI
import System.Glib.Attributes ( Attr
                              , newAttr )
import System.Glib.Properties

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

clockGetFlags :: ClockClass clockT
              => clockT
              -> IO [ClockFlags]
clockGetFlags = mkObjectGetFlags

clockSetFlags :: ClockClass clockT
              => clockT
              -> [ClockFlags]
              -> IO ()
clockSetFlags = mkObjectSetFlags

clockUnsetFlags :: ClockClass clockT
                => clockT
                -> [ClockFlags]
                -> IO ()
clockUnsetFlags = mkObjectUnsetFlags

clockTimeIsValid :: ClockTime
                 -> Bool
clockTimeIsValid = (/= clockTimeNone)

clockAddObservation :: ClockClass clock
                    => clock
                    -> ClockTime
                    -> ClockTime
                    -> IO (Maybe Double)
clockAddObservation clock slave master =
    alloca $ \rSquaredPtr ->
        do success <- {# call clock_add_observation #} (toClock clock)
                                                       (fromIntegral slave)
                                                       (fromIntegral master)
                                                       rSquaredPtr
           if toBool success
               then liftM (Just . realToFrac) $ peek rSquaredPtr
               else return Nothing

clockSetMaster :: (ClockClass clock, ClockClass master)
               => clock
               -> master
               -> IO Bool
clockSetMaster clock master =
    liftM toBool $ {# call clock_set_master #} (toClock clock) (toClock master)

clockGetMaster :: ClockClass clock
               => clock
               -> IO (Maybe Clock)
clockGetMaster clock =
    {# call clock_get_master #} (toClock clock) >>= maybePeek takeObject

clockSetResolution :: ClockClass clock
                   => clock
                   -> ClockTime
                   -> IO ClockTime
clockSetResolution clock resolution =
    liftM fromIntegral $
        {# call clock_set_resolution #} (toClock clock)
                                        (fromIntegral resolution)

clockGetResolution :: ClockClass clock
                   => clock
                   -> IO ClockTime
clockGetResolution clock =
    liftM fromIntegral $
        {# call clock_get_resolution #} (toClock clock)

clockGetTime :: ClockClass clock
             => clock
             -> IO ClockTime
clockGetTime clock =
    liftM fromIntegral $
        {# call clock_get_time #} (toClock clock)

clockNewSingleShotID :: ClockClass clock
                     => clock
                     -> ClockTime
                     -> IO ClockID
clockNewSingleShotID clock time =
    {# call clock_new_single_shot_id #} (toClock clock)
                                        (fromIntegral time) >>=
        takeClockID . castPtr

clockNewPeriodicID :: ClockClass clock
                   => clock
                   -> ClockTime
                   -> ClockTime
                   -> IO ClockID
clockNewPeriodicID clock startTime interval =
    {# call clock_new_periodic_id #} (toClock clock)
                                     (fromIntegral startTime)
                                     (fromIntegral interval) >>=
        takeClockID . castPtr

clockGetInternalTime :: ClockClass clock
                     => clock
                     -> IO ClockTime
clockGetInternalTime clock =
    liftM fromIntegral $
        {# call clock_get_internal_time #} (toClock clock)

clockGetCalibration :: ClockClass clock
                    => clock
                    -> IO (ClockTime, ClockTime, Ratio ClockTime)
clockGetCalibration clock =
    alloca $ \internalPtr ->
        alloca $ \externalPtr ->
            alloca $ \rateNumPtr ->
                alloca $ \rateDenomPtr ->
                    do {# call clock_get_calibration #} (toClock clock)
                                                        internalPtr
                                                        externalPtr
                                                        rateNumPtr
                                                        rateDenomPtr
                       liftM4 (\a b c d ->
                               (fromIntegral a,
                                fromIntegral b,
                                (fromIntegral c) % (fromIntegral d)))
                              (peek internalPtr)
                              (peek externalPtr)
                              (peek rateNumPtr)
                              (peek rateDenomPtr)

clockSetCalibration :: ClockClass clock
                    => clock
                    -> ClockTime
                    -> ClockTime
                    -> Ratio ClockTime
                    -> IO ()
clockSetCalibration clock internal external rate =
    {# call clock_set_calibration #} (toClock clock)
                                     (fromIntegral internal)
                                     (fromIntegral external)
                                     (fromIntegral $ numerator rate)
                                     (fromIntegral $ denominator rate)

clockIDGetTime :: ClockID
               -> IO ClockTime
clockIDGetTime clockID =
    liftM fromIntegral $ withClockID clockID $
        {# call clock_id_get_time #} . castPtr

clockIDWait :: ClockID
            -> IO (ClockReturn, ClockTimeDiff)
clockIDWait clockID =
    alloca $ \jitterPtr ->
        do result <- withClockID clockID $ \clockIDPtr ->
                         {# call clock_id_wait #} (castPtr clockIDPtr) jitterPtr
           jitter <- peek jitterPtr
           return $ (cToEnum result, fromIntegral jitter)

clockIDUnschedule :: ClockID
                  -> IO ()
clockIDUnschedule clockID =
    withClockID clockID $ {# call clock_id_unschedule #} . castPtr

clockTimeout :: ClockClass clockT
             => Attr clockT ClockTime
clockTimeout = newAttr
    (objectGetPropertyUInt64 "timeout")
    (objectSetPropertyUInt64 "timeout")

clockWindowSize :: ClockClass clockT
                => Attr clockT Int
clockWindowSize =
    newAttrFromIntProperty "window-size"

clockWindowThreshold :: ClockClass clockT
                     => Attr clockT Int
clockWindowThreshold =
    newAttrFromIntProperty "window-threshold"


gstreamer: document & implement missing API for M.S.G.Core.ElementFactory

--  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 factory for creating 'Element's.
module Media.Streaming.GStreamer.Core.ElementFactory (

-- * Detail

  -- | 'ElementFactory' is used to create instances of 'Element's.
  --
  --   Use 'elementFactoryFind' and 'elementFactoryCreate' to create
  --   element instances, or use 'elementFactoryMake' as a convenient
  --   shortcut.

-- * Types
  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

-- * ElementFactory Operations
  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryHasInterface,
  elementFactoryCreate,
  elementFactoryMake,
  elementFactoryCanSinkCaps,
  elementFactoryCanSrcCaps,
  elementFactoryGetPadTemplates

  ) where

import Control.Monad         ( liftM
                             , (>=>) )
import Data.Maybe            ( fromMaybe )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
import System.Glib.GList     ( readGList )
{# import Media.Streaming.GStreamer.Core.Types #}

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

-- | Search for an element factory with the given name.
elementFactoryFind :: String                    -- ^ @name@ - the name of the desired factory
                   -> IO (Maybe ElementFactory) -- ^ the factory if found, otherwise 'Nothing'
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= maybePeek takeObject

-- | Get the 'GType' for elements managed by the given factory. The type
--   can only be retrieved if the element factory is loaded, which can
--   be assured with
--   'Media.Streaming.GStreamer.Core.PluginFeature.pluginFeatureLoad'.
elementFactoryGetElementType :: (ElementFactoryClass elementFactory)
                             => elementFactory   -- ^ @factory@ - an element factory
                             -> IO (Maybe GType) -- ^ the type of elements managed
                                                 --   by the factory, or 'Nothing' if
                                                 --   the factory is not loaded
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

-- | Get the long name for the given factory.
elementFactoryGetLongname :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> IO String      -- ^ the factory's long name
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the class for the given factory.
elementFactoryGetKlass :: (ElementFactoryClass elementFactory)
                       => elementFactory -- ^ @factory@ - an element factory
                       -> IO String      -- ^ the factory's class
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the description for the given factory.
elementFactoryGetDescription :: (ElementFactoryClass elementFactory)
                             => elementFactory -- ^ @factory@ - an element factory
                             -> IO String      -- ^ the factory's description
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the author of the given factory.
elementFactoryGetAuthor :: (ElementFactoryClass elementFactory)
                        => elementFactory -- ^ @factory@ - an element factory
                        -> IO String      -- ^ the factory's author
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

-- | Get the number of 'PadTemplate's provided by the given factory.
elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory)
                                 => elementFactory -- ^ @factory@ - an element factory
                                 -> IO Word        -- ^ the number of 'PadTemplate's
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

-- | Get the type of URIs supported by the given factory.
elementFactoryGetURIType :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> IO Int         -- ^ the type of URIs supported by the factory
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

-- | Get the list of protocols supported by the given factory.
elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory)
                              => elementFactory -- ^ @factory@ - an element factory
                              -> IO [String]    -- ^ the supported protocols
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        liftM (fromMaybe []) . maybePeek peekUTFStringArray0

-- | Check if the given factory implements the interface with the given name.
elementFactoryHasInterface :: (ElementFactoryClass elementFactory)
                           => elementFactory -- ^ @factory@ - an element factory
                           -> String         -- ^ @name@ - the interface name
                           -> IO Bool        -- ^ true if the interface is implemented
elementFactoryHasInterface factory name =
    liftM toBool .
        withUTFString name .
        {# call element_factory_has_interface #} .
        toElementFactory $
        factory

-- | Create a new element of the type supplied by the given
--   factory. It will be given the name supplied.
elementFactoryCreate :: (ElementFactoryClass elementFactory)
                     => elementFactory     -- ^ @factory@ - an element factory
                     -> String             -- ^ @name@ - the new element's name
                     -> IO (Maybe Element) -- ^ the new element if it could be created,
                                           --   otherwise 'Nothing'
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

-- | Create a new element of the type supplied by the named
--   factory.
elementFactoryMake :: String             -- ^ @factoryName@ - the name of an element factory
                   -> Maybe String       -- ^ @name@ - the new element's name, or
                                         --   'Nothing' generate a unique name
                   -> IO (Maybe Element) -- ^ the new element if it could be created,
                                         --   otherwise 'Nothing'
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        maybeWith withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject

-- | Check if the given factory can sink the given capabilities.
elementFactoryCanSinkCaps :: (ElementFactoryClass elementFactory)
                          => elementFactory -- ^ @factory@ - an element factory
                          -> Caps           -- ^ @caps@ - the capabilities to check for
                          -> IO Bool        -- ^ 'True' if @factory@ can sink the given capabilities
elementFactoryCanSinkCaps factory caps =
    liftM toBool $ {# call element_factory_can_sink_caps #} (toElementFactory factory) caps

-- | Check if the given factory can source the given capabilities.
elementFactoryCanSrcCaps :: (ElementFactoryClass elementFactory)
                         => elementFactory -- ^ @factory@ - an element factory
                         -> Caps           -- ^ @caps@ - the capabilities to check for
                         -> IO Bool        -- ^ 'True' if @factory@ can source the given capabilities
elementFactoryCanSrcCaps factory caps =
    liftM toBool $ {# call element_factory_can_src_caps #} (toElementFactory factory) caps

-- | Get the pad templates provided by the given factory.
elementFactoryGetPadTemplates :: (ElementFactoryClass elementFactory)
                              => elementFactory   -- ^ @factory@ - an element factory
                              -> IO [PadTemplate] -- ^ the provided pad templates
elementFactoryGetPadTemplates =
    {# call element_factory_get_static_pad_templates #} . toElementFactory >=>
        readGList >=> mapM staticPadTemplateGet

--  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)
module Media.Streaming.GStreamer.Core.ElementFactory (

  ElementFactory,
  ElementFactoryClass,
  castToElementFactory,
  toElementFactory,

  elementFactoryFind,
  elementFactoryGetElementType,
  elementFactoryGetLongname,
  elementFactoryGetKlass,
  elementFactoryGetDescription,
  elementFactoryGetAuthor,
  elementFactoryGetNumPadTemplates,
  elementFactoryGetURIType,
  elementFactoryGetURIProtocols,
  elementFactoryCreate,
  elementFactoryMake

  ) where

import Control.Monad         ( liftM )
import System.Glib.FFI
import System.Glib.UTFString ( withUTFString
                             , peekUTFString
                             , peekUTFStringArray0 )
import System.Glib.GType     ( GType )
{# import Media.Streaming.GStreamer.Core.Types #}

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

elementFactoryFind :: String
                   -> IO ElementFactory
elementFactoryFind name =
    withUTFString name {# call element_factory_find #} >>= takeObject

elementFactoryGetElementType :: (ElementFactoryClass elementFactory) =>
                                elementFactory
                             -> IO (Maybe GType)
elementFactoryGetElementType factory =
    do gtype <- {# call element_factory_get_element_type #} (toElementFactory factory)
       if gtype == 0
          then return $ Just $ fromIntegral gtype
          else return Nothing

elementFactoryGetLongname :: (ElementFactoryClass elementFactory) =>
                             elementFactory
                          -> IO String
elementFactoryGetLongname factory =
    {# call element_factory_get_longname #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetKlass :: (ElementFactoryClass elementFactory) =>
                          elementFactory
                       -> IO String
elementFactoryGetKlass factory =
    {# call element_factory_get_klass #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetDescription :: (ElementFactoryClass elementFactory) =>
                                elementFactory
                             -> IO String
elementFactoryGetDescription factory =
    {# call element_factory_get_description #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetAuthor :: (ElementFactoryClass elementFactory) =>
                           elementFactory
                        -> IO String
elementFactoryGetAuthor factory =
    {# call element_factory_get_author #} (toElementFactory factory) >>=
        peekUTFString

elementFactoryGetNumPadTemplates :: (ElementFactoryClass elementFactory) =>
                                    elementFactory
                                 -> IO Word
elementFactoryGetNumPadTemplates factory =
    liftM fromIntegral $
        {# call element_factory_get_num_pad_templates #} $ toElementFactory factory

elementFactoryGetURIType :: (ElementFactoryClass elementFactory) =>
                            elementFactory
                         -> IO Word
elementFactoryGetURIType factory =
    liftM fromIntegral $
        {# call element_factory_get_uri_type #} $ toElementFactory factory

elementFactoryGetURIProtocols :: (ElementFactoryClass elementFactory) =>
                                 elementFactory
                              -> IO (Maybe [String])
elementFactoryGetURIProtocols factory =
    {# call element_factory_get_uri_protocols #} (toElementFactory factory) >>=
        maybePeek peekUTFStringArray0

elementFactoryCreate :: (ElementFactoryClass elementFactory) =>
                        elementFactory
                     -> String
                     -> IO (Maybe Element)
elementFactoryCreate factory name =
    withUTFString name $ \cName ->
        {# call element_factory_create #} (toElementFactory factory) cName >>=
            maybePeek takeObject

elementFactoryMake :: String
                   -> String
                   -> IO (Maybe Element)
elementFactoryMake factoryName name =
    withUTFString factoryName $ \cFactoryName ->
        withUTFString name $ \cName ->
            {# call element_factory_make #} cFactoryName cName >>=
                maybePeek takeObject


MINOR: sc_copy_context Does Not Call Back

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CUInt(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

-- | Copied from bytestring-0.10.2.0 to make this package only depend on
-- bytestring-0.10.0.0.
unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

-- | 'CSizeT' corresponds to the platform's 'size_t'
type CSizeT = {# type size_t #}

withByteStringLen :: ByteString -> ((CString, CSizeT) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

-- | A shonky encryption key, corresponds to 'shonky_crypt_key_t'
data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

-- Make 'ShonkyCryptKey' storable.
instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

-- Map C and Haskell type for the encryption keys.
{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

-- Get a pointer to the 'sc_release_context' C function.
foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

-- Free 'ShonkyCryptKey's with 'scReleaseContextPtr'
newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $! ShonkyCryptContext fp

-- | 'with' renamed because of c2hs parser
withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS *`ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext *`ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CSizeT -> IO ()
scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
     unsafePerformIO $
     BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
     withShonkyCryptContext ctx $ \ctx' ->
     do
        newContext' <- {#call unsafe sc_copy_context #} ctx'
        outBuffer <- mallocBytes inputLen
        f newContext' inputBytes outBuffer (fromIntegral inputLen)
        out <- unsafePackMallocCStringLen (outBuffer, inputLen)
        newContext <- newShonkyCryptContextPointer newContext'
        return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}

decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CSizeT -> IO CString

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable * #}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CUInt(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

-- | Copied from bytestring-0.10.2.0 to make this package only depend on
-- bytestring-0.10.0.0.
unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

-- | 'CSizeT' corresponds to the platform's 'size_t'
type CSizeT = {# type size_t #}

withByteStringLen :: ByteString -> ((CString, CSizeT) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

-- | A shonky encryption key, corresponds to 'shonky_crypt_key_t'
data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

-- Make 'ShonkyCryptKey' storable.
instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

-- Map C and Haskell type for the encryption keys.
{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

-- Get a pointer to the 'sc_release_context' C function.
foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

-- Free 'ShonkyCryptKey's with 'scReleaseContextPtr'
newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $! ShonkyCryptContext fp

-- | 'with' renamed because of c2hs parser
withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS *`ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext *`ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CSizeT -> IO ()
scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
     unsafePerformIO $
     BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
     withShonkyCryptContext ctx $ \ctx' ->
     do
        newContext' <- {#call sc_copy_context #} ctx'
        outBuffer <- mallocBytes inputLen
        f newContext' inputBytes outBuffer (fromIntegral inputLen)
        out <- unsafePackMallocCStringLen (outBuffer, inputLen)
        newContext <- newShonkyCryptContextPointer newContext'
        return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}

decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CSizeT -> IO CString

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable * #}