gstreamer: remove commented function messageParseAsyncStart in Message.chs

-- 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 Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
module Media.Streaming.GStreamer.Message (

  Message,
  MessageClass,
  castToMessage,
  toMessage,
  fromMessage,
  MessageType(..),
  messageTypeGetName,
  messageTypeToQuark,
  messageSrc,
  messageTimestamp,
  messageType,
  messageTypeName,
  messageStructure,
  messageNewApplication,
  messageParseClockLost,
  messageParseClockProvide,
  messageParseError,
  messageParseInfo,
  messageParseNewClock,
  messageParseSegmentDone,
  messageParseSegmentStart,
  messageParseStateChanged,
  messageParseTag,
  messageParseBuffering,
  messageParseWarning,
  messageParseDuration,

  ) where

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

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

messageTypeGetName :: MessageType
                   -> String
messageTypeGetName messageType =
    unsafePerformIO $
        {# call message_type_get_name #} (fromIntegral $ fromEnum messageType) >>=
            peekUTFString

messageTypeToQuark :: MessageType
                   -> Quark
messageTypeToQuark messageType =
    {# call fun message_type_to_quark #} (fromIntegral $ fromEnum messageType)

messageSrc :: Message
           -> Object
messageSrc message =
    unsafePerformIO $ withMessage message {# get GstMessage->src #} >>=
        newObject_ Object

messageTimestamp :: Message
                 -> ClockTime
messageTimestamp message =
    unsafePerformIO $ withMessage message {# get GstMessage->timestamp #}

messageType :: Message
            -> MessageType
messageType message =
    toEnum $ fromIntegral $ unsafePerformIO $
        withMessage message cMessageGetMessageType
foreign import ccall unsafe "_hs_gst_message_get_message_type"
    cMessageGetMessageType :: Ptr Message
                           -> IO {# type GstMessageType #}

messageTypeName :: Message
                -> String
messageTypeName =
    messageTypeGetName . messageType

messageStructure :: Message
                 -> Structure
messageStructure message =
    unsafePerformIO $ {# call message_get_structure #} message >>= newStructure_

messageNewApplication :: Object
                      -> Structure
                      -> IO Message
messageNewApplication object structure =
    (giveStructure structure $ {# call message_new_application #} object) >>=
        newMessage

messageParseClockLost :: Message
                      -> Maybe Clock
messageParseClockLost message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           liftM Just $ peek clockPtr >>= newClock_

messageParseClockProvide :: Message
                         -> Maybe (Clock, Bool)
messageParseClockProvide message =
    unsafePerformIO $ alloca $ \clockPtr ->
        alloca $ \readyPtr ->
            do poke clockPtr nullPtr
               poke readyPtr $ fromBool False
               {# call message_parse_clock_provide #} message (castPtr clockPtr) readyPtr
               clock <- peek clockPtr >>= maybePeek newClock_
               ready <- peek readyPtr
               return $ maybe Nothing (\clock -> Just (clock, toBool ready)) clock

messageParseError :: Message
                  -> (Maybe GError, Maybe String)
messageParseError message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_error #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseInfo :: Message
                 -> (Maybe GError, Maybe String)
messageParseInfo message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_info #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseNewClock :: Message
                     -> Maybe Clock
messageParseNewClock message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           peek clockPtr >>= maybePeek newClock_

messageParseSegmentDone :: Message
                        -> (Format, Int64)
messageParseSegmentDone message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_done #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseSegmentStart :: Message
                         -> (Format, Int64)
messageParseSegmentStart message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_start #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseStateChanged :: Message
                         -> (State, State, State)
messageParseStateChanged message =
    unsafePerformIO $ alloca $ \oldStatePtr ->
        alloca $ \newStatePtr -> alloca $ \pendingPtr ->
            do poke oldStatePtr 0
               poke newStatePtr 0
               poke pendingPtr  0
               {# call message_parse_state_changed #} message oldStatePtr newStatePtr pendingPtr
               oldState <- liftM (toEnum . fromIntegral) $ peek oldStatePtr
               newState <- liftM (toEnum . fromIntegral) $ peek newStatePtr
               pending  <- liftM (toEnum . fromIntegral) $ peek pendingPtr
               return (oldState, newState, pending)

messageParseTag :: Message
                -> TagList
messageParseTag message =
    unsafePerformIO $ alloca $ \tagListPtr ->
        do poke tagListPtr nullPtr
           {# call message_parse_tag #} message $ castPtr tagListPtr
           peek tagListPtr >>= newTagList

messageParseBuffering :: Message
                      -> Int
messageParseBuffering message =
    fromIntegral $ unsafePerformIO $ alloca $ \percentPtr ->
        do poke percentPtr 0
           {# call message_parse_buffering #} message percentPtr
           peek percentPtr

messageParseWarning :: Message
                    -> (Maybe GError, Maybe String)
messageParseWarning message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_warning #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseDuration :: Message
                     -> (Format, Int64)
messageParseDuration message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_duration #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

-- 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 Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
module Media.Streaming.GStreamer.Message (

  Message,
  MessageClass,
  castToMessage,
  toMessage,
  fromMessage,
  MessageType(..),
  messageTypeGetName,
  messageTypeToQuark,
  messageSrc,
  messageTimestamp,
  messageType,
  messageTypeName,
  messageStructure,
  messageNewApplication,
  messageParseClockLost,
  messageParseClockProvide,
  messageParseError,
  messageParseInfo,
  messageParseNewClock,
  messageParseSegmentDone,
  messageParseSegmentStart,
  messageParseStateChanged,
  messageParseTag,
  messageParseBuffering,
  messageParseWarning,
  messageParseDuration,
  --messageParseAsyncStart
  ) where

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

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

messageTypeGetName :: MessageType
                   -> String
messageTypeGetName messageType =
    unsafePerformIO $
        {# call message_type_get_name #} (fromIntegral $ fromEnum messageType) >>=
            peekUTFString

messageTypeToQuark :: MessageType
                   -> Quark
messageTypeToQuark messageType =
    {# call fun message_type_to_quark #} (fromIntegral $ fromEnum messageType)

messageSrc :: Message
           -> Object
messageSrc message =
    unsafePerformIO $ withMessage message {# get GstMessage->src #} >>=
        newObject_ Object

messageTimestamp :: Message
                 -> ClockTime
messageTimestamp message =
    unsafePerformIO $ withMessage message {# get GstMessage->timestamp #}

messageType :: Message
            -> MessageType
messageType message =
    toEnum $ fromIntegral $ unsafePerformIO $
        withMessage message cMessageGetMessageType
foreign import ccall unsafe "_hs_gst_message_get_message_type"
    cMessageGetMessageType :: Ptr Message
                           -> IO {# type GstMessageType #}

messageTypeName :: Message
                -> String
messageTypeName =
    messageTypeGetName . messageType

messageStructure :: Message
                 -> Structure
messageStructure message =
    unsafePerformIO $ {# call message_get_structure #} message >>= newStructure_

messageNewApplication :: Object
                      -> Structure
                      -> IO Message
messageNewApplication object structure =
    (giveStructure structure $ {# call message_new_application #} object) >>=
        newMessage

messageParseClockLost :: Message
                      -> Maybe Clock
messageParseClockLost message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           liftM Just $ peek clockPtr >>= newClock_

messageParseClockProvide :: Message
                         -> Maybe (Clock, Bool)
messageParseClockProvide message =
    unsafePerformIO $ alloca $ \clockPtr ->
        alloca $ \readyPtr ->
            do poke clockPtr nullPtr
               poke readyPtr $ fromBool False
               {# call message_parse_clock_provide #} message (castPtr clockPtr) readyPtr
               clock <- peek clockPtr >>= maybePeek newClock_
               ready <- peek readyPtr
               return $ maybe Nothing (\clock -> Just (clock, toBool ready)) clock

messageParseError :: Message
                  -> (Maybe GError, Maybe String)
messageParseError message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_error #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseInfo :: Message
                 -> (Maybe GError, Maybe String)
messageParseInfo message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_info #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseNewClock :: Message
                     -> Maybe Clock
messageParseNewClock message =
    unsafePerformIO $ alloca $ \clockPtr ->
        do poke clockPtr nullPtr
           {# call message_parse_clock_lost #} message $ castPtr clockPtr
           peek clockPtr >>= maybePeek newClock_

messageParseSegmentDone :: Message
                        -> (Format, Int64)
messageParseSegmentDone message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_done #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseSegmentStart :: Message
                         -> (Format, Int64)
messageParseSegmentStart message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_segment_start #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

messageParseStateChanged :: Message
                         -> (State, State, State)
messageParseStateChanged message =
    unsafePerformIO $ alloca $ \oldStatePtr ->
        alloca $ \newStatePtr -> alloca $ \pendingPtr ->
            do poke oldStatePtr 0
               poke newStatePtr 0
               poke pendingPtr  0
               {# call message_parse_state_changed #} message oldStatePtr newStatePtr pendingPtr
               oldState <- liftM (toEnum . fromIntegral) $ peek oldStatePtr
               newState <- liftM (toEnum . fromIntegral) $ peek newStatePtr
               pending  <- liftM (toEnum . fromIntegral) $ peek pendingPtr
               return (oldState, newState, pending)

messageParseTag :: Message
                -> TagList
messageParseTag message =
    unsafePerformIO $ alloca $ \tagListPtr ->
        do poke tagListPtr nullPtr
           {# call message_parse_tag #} message $ castPtr tagListPtr
           peek tagListPtr >>= newTagList

messageParseBuffering :: Message
                      -> Int
messageParseBuffering message =
    fromIntegral $ unsafePerformIO $ alloca $ \percentPtr ->
        do poke percentPtr 0
           {# call message_parse_buffering #} message percentPtr
           peek percentPtr

messageParseWarning :: Message
                    -> (Maybe GError, Maybe String)
messageParseWarning message =
    unsafePerformIO $ alloca $ \gErrorPtr ->
        alloca $ \debugPtr ->
            do poke gErrorPtr nullPtr
               poke debugPtr nullPtr
               {# call message_parse_warning #} message (castPtr gErrorPtr) debugPtr
               gError <- peek gErrorPtr >>=
                             (maybePeek $ \ptr ->
                              do gError <- peek ptr
                                 {# call g_error_free #} $ castPtr ptr
                                 return gError)
               debug <- peek debugPtr >>= maybePeek readUTFString
               return (gError, debug)

messageParseDuration :: Message
                     -> (Format, Int64)
messageParseDuration message =
    unsafePerformIO $ alloca $ \formatPtr ->
        alloca $ \positionPtr ->
            do poke formatPtr $ fromIntegral $ fromEnum FormatUndefined
               poke positionPtr 0
               {# call message_parse_duration #} message formatPtr positionPtr
               format <- peek formatPtr
               position <- peek positionPtr
               return (toEnum $ fromIntegral format, fromIntegral position)

{-
messageParseAsyncStart :: Message
                       -> Bool
messageParseAsyncStart message =
    toBool $ unsafePerformIO $ alloca $ \newBaseTimePtr ->
        do poke newBaseTimePtr $ fromBool False
           {# call message_parse_async_start #} message newBaseTimePtr
           peek newBaseTimePtr
-}


Added skeletonization to Morphology

Added skeletonization to Morphology

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, UnicodeSyntax, ViewPatterns#-}
#include "cvWrapLEO.h"
module CV.Morphology (StructuringElement
                  ,structuringElement
                  ,customSE
                  ,basicSE,bigSE
                  ,geodesic
                  ,openOp,closeOp
                  ,open,close
                  ,erode,dilate
                  ,blackTopHat,whiteTopHat
                  ,skeletonize
                  ,dilateOp,erodeOp,KernelShape(EllipseShape,CrossShape,RectShape)
                  , ConvKernel
                  )
where

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Array

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import System.IO.Unsafe

-- Morphological opening
openOp :: StructuringElement -> ImageOperation GrayScale d
openOp se = erodeOp se 1 #> dilateOp se 1
open se = unsafeOperate (openOp se)
a ○ b = open b a
-- a ○ b = (a ⊖ b) ⊕ b

-- Morphological closing
closeOp :: StructuringElement -> ImageOperation GrayScale d
closeOp se = dilateOp se 1 #> erodeOp se 1
close se = unsafeOperate (closeOp se)
a ● b = close b a

geodesic :: Image GrayScale D32 -> ImageOperation GrayScale d -> ImageOperation GrayScale d
geodesic mask op = op #> IM.limitToOp mask

-- | Perform a black tophat filtering of size
blackTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (closeOp se) i
                  in x `IM.sub` i

-- | Perform a white tophat filtering of size
whiteTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (openOp se) i
                  in i `IM.sub` x

basicSE = structuringElement (3,3) (1,1) RectShape
bigSE = structuringElement (9,9) (4,4) RectShape

---------- Low level wrapper
#c
enum KernelShape {
    RectShape    = CV_SHAPE_RECT
    ,CrossShape   = CV_SHAPE_CROSS
    ,EllipseShape = CV_SHAPE_ELLIPSE
    ,CustomShape  = CV_SHAPE_CUSTOM
    };
#endc
{#enum KernelShape {} #}

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

foreign import ccall "& wrapReleaseStructuringElement"
    releaseSE :: FinalizerPtr ConvKernel

-- Check morphology element
isGoodSE s@(w,h) d@(x,y) | x>=0 && y>=0
                         && w>=0 && h>=0
                         && x<w  && y<h
                         = True

                         | otherwise = False

-- |Create a structuring element for morphological operations
-- The first pair is @(width,height)@ while the second is the origin @(x,y)@
structuringElement :: (Int, Int) -> (Int, Int) -> KernelShape -> StructuringElement
structuringElement s d | isGoodSE s d = createSE s d
                       | otherwise = error "Bad values in structuring element"

-- Create SE with custom shape that is taken from flat list shape.
createSE :: (Int, Int) -> (Int, Int) -> KernelShape -> StructuringElement
createSE (fromIntegral -> w,fromIntegral -> h) (fromIntegral -> x,fromIntegral -> y) shape = unsafePerformIO $ do
    iptr <- {#call cvCreateStructuringElementEx#}
             w h x y (fromIntegral . fromEnum $ shape) nullPtr
    fptr <- newForeignPtr releaseSE iptr
    return (ConvKernel fptr)

customSE :: (CInt, CInt) -> (CInt, CInt) -> [CInt] -> ConvKernel
customSE s@(w,h) o shape | isGoodSE s o
                         && length shape == fromIntegral (w*h)
                            = createCustomSE s o shape

createCustomSE (w,h) (x,y) shape = unsafePerformIO $ do
            iptr <- withArray shape $ \arr ->
                    {#call cvCreateStructuringElementEx#}
                      w h x y (fromIntegral . fromEnum $ CustomShape) arr
            fptr <- newForeignPtr releaseSE iptr
            return (ConvKernel fptr)

{#fun cvErode as erosion
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}
{#fun cvDilate as dilation
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}

erodeOp se count = ImgOp $ \(unS -> img)  -> erosion img img se count
dilateOp se count = ImgOp $ \(unS -> img) -> dilation img img se count

erode se count  i = unsafeOperate (erodeOp se count)  i
dilate se count i = unsafeOperate (dilateOp se count) i

a ⊕ b = dilate b 1 a
a ⊖ b = erode b 1 a

erode' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvErode#} (castPtr image)
                              (castPtr image)
                              ck count

dilate' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvDilate#} (castPtr image)
                              (castPtr image)
                              ck count

skeletonize :: Image GrayScale D8 -> Image GrayScale D8
skeletonize i = fst . snd . head . dropWhile (\x -> fst x > 0) . iterate (skeletonize'.snd)
                $ (1,(CV.Image.empty (getSize i),i))
skeletonize' :: (Image GrayScale D8, Image GrayScale D8) -> (Int, (Image GrayScale D8, Image GrayScale D8))
skeletonize' (skel,img) = (countNonZero tmp, (tmp, erode se 1 img))
    where
       tmp = unsafeOperateOn img $ openOp se #> IM.notOp #> IM.andOp img Nothing #> IM.orOp skel Nothing
       se = structuringElement (3,3) (1,1) CrossShape

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, UnicodeSyntax, ViewPatterns#-}
#include "cvWrapLEO.h"
module CV.Morphology (StructuringElement
                  ,structuringElement
                  ,customSE
                  ,basicSE,bigSE
                  ,geodesic
                  ,openOp,closeOp
                  ,open,close
                  ,erode,dilate
                  ,blackTopHat,whiteTopHat
                  ,dilateOp,erodeOp,KernelShape(EllipseShape,CrossShape,RectShape)
                  , ConvKernel
                  )
where

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal.Array

import CV.Image

import CV.ImageOp
import qualified CV.ImageMath as IM

import System.IO.Unsafe

-- Morphological opening
openOp :: StructuringElement -> ImageOperation GrayScale d
openOp se = erodeOp se 1 #> dilateOp se 1
open se = unsafeOperate (openOp se)
a ○ b = open b a
-- a ○ b = (a ⊖ b) ⊕ b

-- Morphological closing
closeOp :: StructuringElement -> ImageOperation GrayScale d
closeOp se = dilateOp se 1 #> erodeOp se 1
close se = unsafeOperate (closeOp se)
a ● b = close b a

geodesic :: Image GrayScale D32 -> ImageOperation GrayScale d -> ImageOperation GrayScale d
geodesic mask op = op #> IM.limitToOp mask

-- | Perform a black tophat filtering of size
blackTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (closeOp se) i
                  in x `IM.sub` i

-- | Perform a white tophat filtering of size
whiteTopHat size i =
                  let se = structuringElement
                        (size,size) (size `div` 2, size `div` 2) RectShape
                      x  = unsafeOperate (openOp se) i
                  in i `IM.sub` x

basicSE = structuringElement (3,3) (1,1) RectShape
bigSE = structuringElement (9,9) (4,4) RectShape

---------- Low level wrapper
#c
enum KernelShape {
    RectShape    = CV_SHAPE_RECT
    ,CrossShape   = CV_SHAPE_CROSS
    ,EllipseShape = CV_SHAPE_ELLIPSE
    ,CustomShape  = CV_SHAPE_CUSTOM
    };
#endc
{#enum KernelShape {} #}

{#pointer *IplConvKernel as ConvKernel foreign newtype#}

type StructuringElement = ConvKernel

foreign import ccall "& wrapReleaseStructuringElement"
    releaseSE :: FinalizerPtr ConvKernel

-- Check morphology element
isGoodSE s@(w,h) d@(x,y) | x>=0 && y>=0
                         && w>=0 && h>=0
                         && x<w  && y<h
                         = True

                         | otherwise = False

-- |Create a structuring element for morphological operations
-- The first pair is @(width,height)@ while the second is the origin @(x,y)@
structuringElement :: (Int, Int) -> (Int, Int) -> KernelShape -> StructuringElement
structuringElement s d | isGoodSE s d = createSE s d
                       | otherwise = error "Bad values in structuring element"

-- Create SE with custom shape that is taken from flat list shape.
createSE :: (Int, Int) -> (Int, Int) -> KernelShape -> StructuringElement
createSE (fromIntegral -> w,fromIntegral -> h) (fromIntegral -> x,fromIntegral -> y) shape = unsafePerformIO $ do
    iptr <- {#call cvCreateStructuringElementEx#}
             w h x y (fromIntegral . fromEnum $ shape) nullPtr
    fptr <- newForeignPtr releaseSE iptr
    return (ConvKernel fptr)

customSE :: (CInt, CInt) -> (CInt, CInt) -> [CInt] -> ConvKernel
customSE s@(w,h) o shape | isGoodSE s o
                         && length shape == fromIntegral (w*h)
                            = createCustomSE s o shape

createCustomSE (w,h) (x,y) shape = unsafePerformIO $ do
            iptr <- withArray shape $ \arr ->
                    {#call cvCreateStructuringElementEx#}
                      w h x y (fromIntegral . fromEnum $ CustomShape) arr
            fptr <- newForeignPtr releaseSE iptr
            return (ConvKernel fptr)

{#fun cvErode as erosion
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}
{#fun cvDilate as dilation
    {withGenBareImage* `BareImage'
    ,withGenBareImage* `BareImage'
    ,withConvKernel* `ConvKernel'
    ,`Int'} -> `()' #}

erodeOp se count = ImgOp $ \(unS -> img)  -> erosion img img se count
dilateOp se count = ImgOp $ \(unS -> img) -> dilation img img se count

erode se count  i = unsafeOperate (erodeOp se count)  i
dilate se count i = unsafeOperate (dilateOp se count) i

a ⊕ b = dilate b 1 a
a ⊖ b = erode b 1 a

erode' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvErode#} (castPtr image)
                              (castPtr image)
                              ck count

dilate' se count img = withImage img $ \image ->
               withConvKernel se $ \ck ->
             {#call cvDilate#} (castPtr image)
                              (castPtr image)
                              ck count


Added some documentation

Added some documentation

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
module CV.Transforms where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip axis img = unsafePerformIO $ do
                 cl <- emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate angle img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       target <- emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

-- | Scale image by a ratio on both axes
scaleSingleRatio tpe x img = scale tpe (x,x) img

-- | Scale an image
scale :: (RealFloat a) => Interpolation -> (a,a) -> Image GrayScale D32 -> Image GrayScale D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

scaleToSize :: Interpolation -> Bool -> (Int,Int) -> Image GrayScale D32 -> Image GrayScale D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

oneParamPerspective img k
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call simplePerspective#} k cimg

perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- | Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- | Enlarge image so, that it's size is divisible by 2^n
-- TODO: Could have wider type
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
    CV_DIST_C
    ,CV_DIST_L1
    ,CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
module CV.Transforms where

import CV.Image
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp

-- |Since DCT is valid only for even sized images, we provide a
-- function to crop images to even sizes.
takeEvenSized img = getRegion (0,0) (w-wadjust,h-hadjust) img
    where
     (w,h) = getSize img
     hadjust | odd h = 1
             | otherwise = 2
     wadjust | odd w = 1
             | otherwise = 2

-- |Perform Discrete Cosine Transform
dct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 0)
        | otherwise = error "DCT needs even sized image"

-- |Perform Inverse Discrete Cosine Transform
idct img | (x,y) <- getSize img, even x && even y
        = unsafePerformIO $
            withGenImage img $ \i ->
              withClone img $ \c' ->
                withGenImage c' $ \c ->
                  ({#call cvDCT#} i c 1)
        | otherwise = error "IDCT needs even sized image"

data MirrorAxis = Vertical | Horizontal deriving (Show,Eq)

-- |Mirror an image over a cardinal axis
flip axis img = unsafePerformIO $ do
                 cl <- emptyCopy img
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

-- |Rotate `img` `angle` radians.
rotate angle img = unsafePerformIO $
                    withImage img $ \i ->
                        creatingImage
                         ({#call rotateImage#} i 1 angle)

data Interpolation = NearestNeighbour | Linear
                   | Area | Cubic
                deriving (Eq,Ord,Enum,Show)

-- |Simulate a radial distortion over an image
radialDistort :: Image GrayScale D32 -> Double -> Image GrayScale D32
radialDistort img k = unsafePerformIO $ do
                       target <- emptyCopy img
                       withImage img $ \cimg ->
                        withImage target $ \ctarget ->
                         {#call radialRemap#} cimg ctarget (realToFrac k)
                       return target

scaleSingleRatio tpe x img = scale tpe (x,x) img

scale :: (RealFloat a) => Interpolation -> (a,a) -> Image GrayScale D32 -> Image GrayScale D32
scale tpe (x,y) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (w,h) = getSize img
             (w',h') = (round $ fromIntegral w*y
                       ,round $ fromIntegral h*x)

scaleToSize :: Interpolation -> Bool -> (Int,Int) -> Image GrayScale D32 -> Image GrayScale D32
scaleToSize tpe retainRatio (w,h) img = unsafePerformIO $ do
                    target <- create (w',h')
                    withGenImage img $ \i ->
                     withGenImage target $ \t ->
                        {#call cvResize#} i t
                            (fromIntegral.fromEnum $ tpe)
                    return target
            where
             (ow,oh) = getSize img
             (w',h') = if retainRatio
                         then (floor $ fromIntegral ow*ratio,floor $ fromIntegral oh*ratio)
                         else (w,h)
             ratio  = max (fromIntegral w/fromIntegral ow)
                          (fromIntegral h/fromIntegral oh)

oneParamPerspective img k
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call simplePerspective#} k cimg

perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

--- Pyramid transforms
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

sameSizePad img img2 = if (size1 /= size2)
              then unsafePerformIO $ do
                r <- creatingImage $
                       withGenImage img2 $ \cImg -> {#call padUp#} cImg (toI $ w2<w1) (toI $ h2<h1)
                if getSize r /= getSize img
                    then error ("Couldn't pad: "++show size1++"/"++show size2)
                    else return r
              else img
    where
     toI True = 1
     toI False = 0
     size1@(w1,h1)  = getSize img
     size2@(w2,h2)  = getSize img2

cv_Gaussian = 7
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

-- TODO: For additional efficiency, make this so that pyrDown result is directly put into
--       proper size image which is then padded
safePyrDown img = evenize result
    where
     result = pyrDown img
     (w,h)  = getSize result

laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

-- | Reconstruct an image from a laplacian pyramid
reconstructFromLaplacian pyramid = foldl1 (\a b -> (pyrUp a) #+ b) (pyramid)
  --  where
  --   safeAdd x y = sameSizePad y x #+ y

-- | Enlarge image so, that it's size is divisible by 2^n
-- TODO: Could have wider type
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
    CV_DIST_C
    ,CV_DIST_L1
    ,CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

-- |Mask sizes accepted by distanceTransform
data MaskSize = M3 | M5 deriving (Eq,Ord,Enum,Show)

-- |Perform a distance transform on the image
distanceTransform :: DistanceType -> MaskSize -> Image GrayScale D8 -> Image GrayScale D32 --TODO: Input should be a black and white image
distanceTransform dtype maskSize source = unsafePerformIO $ do
    result :: Image GrayScale D32 <- create (getSize source)
    withGenImage source $ \c_source ->
     withGenImage result $ \c_result ->
        {#call cvDistTransform #} c_source c_result
                                  (fromIntegral . fromEnum $ dtype)
                                  (fromIntegral . fromEnum $ maskSize)
                                   nullPtr nullPtr
    return result
    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks


Refactoring

Refactoring

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Primitive
import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type Ptr2Int = Ptr () -> IO CInt

newtype ObjDB      = ObjDB { unODB :: Ptr () }
newtype Repository = Repository { unRepository :: Ptr () }
newtype Index      = Index { unIndex :: Ptr () }

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res        <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  retEither res $ fmap (Right . Repository) $ peek pprepo

-- TODO: size? GIT_EXTERN(int) git_repository_discover(char *repository_path, size_t size, const char *start_path, int across_fs, const char *ceiling_dirs);
discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res    <- {#call git_repository_discover#} path undefined spStr (fromBool acrossFs) cdsStr
  retEither res $ undefined

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  retEither res $ fmap (Right . Index) $ peek idx

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

-- TODO: Refactor some bits
init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  retEither res $ fmap (Right . Repository) $ peek pprepo

-- TODO: Add tysig
retEither res f | res == 0  = f
                | otherwise = return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}

#include "git2.h"

module Git2 where

import Data.Primitive
import Foreign
import Foreign.C.String
import Foreign.C.Types

type OffT    = {#type git_off_t#}
type TimeT   = {#type git_time_t#}
type Ptr2Int = Ptr () -> IO CInt

newtype ObjDB      = ObjDB { unODB :: Ptr () }
newtype Repository = Repository { unRepository :: Ptr () }
newtype Index      = Index { unIndex :: Ptr () }

{#enum git_otype as OType {underscoreToCase}#}
{#enum git_rtype as RType {underscoreToCase}#}
{#enum git_repository_pathid as RepositoryPathID {underscoreToCase}#}
{#enum git_error as GitError {underscoreToCase}#}
{#enum git_odb_streammode as ODBStreamMode {underscoreToCase}#}

deriving instance Show GitError

repoIs :: Ptr2Int -> Repository -> IO Bool
repoIs ffi (Repository ptr) = return . toBool =<< ffi ptr

openRepo :: String -> IO (Either GitError Repository)
openRepo path = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_open#} pprepo pstr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

openRepoObjDir :: String -> String -> String -> String -> IO (Either GitError Repository)
openRepoObjDir dir objDir idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  objDirStr  <- newCString objDir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res  <- {#call git_repository_open2#} pprepo dirStr objDirStr idxFileStr wtreeStr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

openRepoObjDb :: String -> ObjDB -> String -> String -> IO (Either GitError Repository)
openRepoObjDb dir (ObjDB db) idxFile workTree = alloca $ \pprepo -> do
  dirStr     <- newCString dir
  idxFileStr <- newCString idxFile
  wtreeStr   <- newCString workTree
  res  <- {#call git_repository_open3#} pprepo dirStr db idxFileStr wtreeStr
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

-- TODO: size? GIT_EXTERN(int) git_repository_discover(char *repository_path, size_t size, const char *start_path, int across_fs, const char *ceiling_dirs);
discover :: String -> Bool -> String -> IO (Either GitError String)
discover startPath acrossFs ceilingDirs = alloca $ \path -> do
  spStr  <- newCString startPath
  cdsStr <- newCString ceilingDirs
  res <-{#call git_repository_discover#} path undefined spStr (fromBool acrossFs) cdsStr
  if res == 0
    then undefined
    else return . Left . toEnum . fromIntegral $ res

database :: Repository -> IO ObjDB
database (Repository r) = return . ObjDB =<< {#call git_repository_database#} r

index :: Repository -> IO (Either GitError Index)
index (Repository r) = alloca $ \idx -> do
  res  <- {#call git_repository_index#} idx r
  if res == 0
    then fmap (Right . Index) $ peek idx
    else return . Left . toEnum . fromIntegral $ res

free :: Repository -> IO ()
free (Repository r) = {#call git_repository_free#} r

-- TODO: Refactor some bits
init :: String -> Bool -> IO (Either GitError Repository)
init path isBare = alloca $ \pprepo -> do
  pstr <- newCString path
  res  <- {#call git_repository_init#} pprepo pstr (fromBool isBare)
  if res == 0
    then fmap (Right . Repository) $ peek pprepo
    else return . Left . toEnum . fromIntegral $ res

isHeadDetached :: Repository -> IO Bool
isHeadDetached = repoIs {#call git_repository_head_detached#}

isHeadOrphan :: Repository -> IO Bool
isHeadOrphan = repoIs {#call git_repository_head_orphan#}

isEmpty :: Repository -> IO Bool
isEmpty = repoIs {#call git_repository_is_empty#}

path :: Repository -> RepositoryPathID -> IO String
path (Repository r) pathID = peekCString =<< {#call git_repository_path#} r p
  where p = fromIntegral $ fromEnum pathID

isBare :: Repository -> IO Bool
isBare = repoIs {#call git_repository_is_bare#}


Don't bind attributes we don't understand.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValueTypes
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This is used by the implementation of properties and by the
-- 'Graphics.UI.Gtk.TreeList.TreeModel' and
-- related modules.
--
module System.Glib.GValueTypes (
  valueSetUInt,
  valueGetUInt,
  valueSetInt,
  valueGetInt,
  valueSetUInt64,
  valueGetUInt64,
  valueSetInt64,
  valueGetInt64,
  valueSetUChar,
  valueGetUChar,
  valueSetChar,
  valueGetChar,
  valueSetBool,
  valueGetBool,
  valueSetPointer,
  valueGetPointer,
  valueSetFloat,
  valueGetFloat,
  valueSetDouble,
  valueGetDouble,
  valueSetEnum,
  valueGetEnum,
  valueSetFlags,
  valueGetFlags,
  valueSetString,
  valueGetString,
  valueSetMaybeString,
  valueGetMaybeString,
  valueSetBoxed,
  valueGetBoxed,
  valueSetGObject,
  valueGetGObject,
  valueSetMaybeGObject,
  valueGetMaybeGObject,
  ) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.UTFString
{#import System.Glib.GValue#}		(GValue(GValue))
import System.Glib.GObject

{# context lib="glib" prefix="g" #}

valueSetUInt :: GValue -> Word -> IO ()
valueSetUInt gvalue value =
  {# call unsafe value_set_uint #} gvalue (fromIntegral value)

valueGetUInt :: GValue -> IO Word
valueGetUInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint #} gvalue

valueSetInt :: GValue -> Int -> IO ()
valueSetInt gvalue value =
  {# call unsafe value_set_int #} gvalue (fromIntegral value)

valueGetInt :: GValue -> IO Int
valueGetInt gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int #} gvalue

valueSetUInt64 :: GValue -> Word64 -> IO ()
valueSetUInt64 gvalue value =
  {# call unsafe value_set_uint64 #} gvalue (fromIntegral value)

valueGetUInt64 :: GValue -> IO Word64
valueGetUInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_uint64 #} gvalue

valueSetInt64 :: GValue -> Int64 -> IO ()
valueSetInt64 gvalue value =
  {# call unsafe value_set_int64 #} gvalue (fromIntegral value)

valueGetInt64 :: GValue -> IO Int64
valueGetInt64 gvalue =
  liftM fromIntegral $
  {# call unsafe value_get_int64 #} gvalue

valueSetUChar :: GValue -> Word8 -> IO ()
valueSetUChar gvalue value =
  {# call unsafe value_set_uchar #} gvalue (fromIntegral value)

valueGetUChar :: GValue -> IO Word8
valueGetUChar gvalue =
  liftM fromIntegral $ {# call unsafe value_get_uchar #} gvalue

--these belong somewhere else, are in new c2hs's C2HS module
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . fromIntegral

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = fromIntegral . fromEnum

--valueSetChar :: GValue -> {#type gchar#} -> IO ()
valueSetChar :: GValue -> Char -> IO ()
valueSetChar gvalue value =
  {# call unsafe value_set_char #} gvalue (cFromEnum value)

--valueGetChar :: GValue -> IO {#type gchar#}
valueGetChar :: GValue -> IO Char
valueGetChar gvalue =
  liftM cToEnum $ {# call unsafe value_get_char #} gvalue

valueSetBool :: GValue -> Bool -> IO ()
valueSetBool gvalue value =
  {# call unsafe value_set_boolean #} gvalue (fromBool value)

valueGetBool :: GValue -> IO Bool
valueGetBool gvalue =
  liftM toBool $
  {# call  unsafe value_get_boolean #} gvalue

-- These functions should probably never be used as they are dangerous.
--
valueSetPointer :: GValue -> (Ptr ()) -> IO ()
valueSetPointer gvalue value =
  {# call unsafe value_set_pointer #} gvalue value

valueGetPointer :: GValue -> IO (Ptr ())
valueGetPointer gvalue =
  {# call unsafe value_get_pointer #} gvalue

valueSetFloat :: GValue -> Float -> IO ()
valueSetFloat gvalue value =
  {# call unsafe value_set_float #} gvalue (realToFrac value)

valueGetFloat :: GValue -> IO Float
valueGetFloat gvalue =
  liftM realToFrac $
  {# call unsafe value_get_float #} gvalue

valueSetDouble :: GValue -> Double -> IO ()
valueSetDouble gvalue value =
  {# call unsafe value_set_double #} gvalue (realToFrac value)

valueGetDouble :: GValue -> IO Double
valueGetDouble gvalue =
  liftM realToFrac $
  {# call unsafe value_get_double #} gvalue

valueSetEnum :: Enum enum => GValue -> enum -> IO ()
valueSetEnum gvalue value =
  {# call unsafe value_set_enum #} gvalue (fromIntegral $ fromEnum value)

valueGetEnum :: Enum enum => GValue -> IO enum
valueGetEnum gvalue =
  liftM (toEnum . fromIntegral) $
  {# call unsafe value_get_enum #} gvalue

valueSetFlags :: Flags flag => GValue -> [flag] -> IO ()
valueSetFlags gvalue value =
  {# call unsafe value_set_flags #} gvalue (fromIntegral $ fromFlags value)

valueGetFlags :: Flags flag => GValue -> IO [flag]
valueGetFlags gvalue =
  liftM (toFlags . fromIntegral) $
  {# call unsafe value_get_flags #} gvalue

valueSetString :: GValue -> String -> IO ()
valueSetString gvalue str =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueGetString :: GValue -> IO String
valueGetString gvalue = do
  strPtr <- {# call unsafe value_get_string #} gvalue
  if strPtr == nullPtr
    then return ""
    else peekUTFString strPtr

valueSetMaybeString :: GValue -> Maybe String -> IO ()
valueSetMaybeString gvalue (Just str) =
  withUTFString str $ \strPtr ->
  {# call unsafe value_set_string #} gvalue strPtr

valueSetMaybeString gvalue Nothing =
  {# call unsafe value_set_static_string #} gvalue nullPtr

valueGetMaybeString :: GValue -> IO (Maybe String)
valueGetMaybeString gvalue =
  {# call unsafe value_get_string #} gvalue
  >>= maybePeek peekUTFString

valueSetBoxed :: (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GValue -> boxed -> IO ()
valueSetBoxed with gvalue boxed =
  with boxed $ \boxedPtr -> do
  {# call unsafe g_value_set_boxed #} gvalue (castPtr boxedPtr)

valueGetBoxed :: (Ptr boxed -> IO boxed) -> GValue -> IO boxed
valueGetBoxed peek gvalue =
  {# call unsafe g_value_get_boxed #} gvalue >>= peek . castPtr

-- for some weird reason the API says that gv is a gpointer, not a GObject
--
valueSetGObject :: GObjectClass gobj => GValue -> gobj -> IO ()
valueSetGObject gvalue obj =
  withForeignPtr ((unGObject.toGObject) obj) $ \objPtr ->
    {# call unsafe g_value_set_object #} gvalue (castPtr objPtr)

-- Unsafe because it performs an unchecked downcast. Only for internal use.
--
valueGetGObject :: GObjectClass gobj => GValue -> IO gobj
valueGetGObject gvalue =
  liftM unsafeCastGObject $
  makeNewGObject mkGObject $
  throwIfNull "GValue.valueGetObject: extracting invalid object" $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue

valueSetMaybeGObject :: GObjectClass gobj => GValue -> (Maybe gobj) -> IO ()
valueSetMaybeGObject gvalue (Just obj) = valueSetGObject gvalue obj
valueSetMaybeGObject gvalue Nothing =
    {# call unsafe g_value_set_object #} gvalue nullPtr

valueGetMaybeGObject :: GObjectClass gobj => GValue -> IO (Maybe gobj)
valueGetMaybeGObject gvalue =
  liftM (liftM unsafeCastGObject) $
  maybeNull (makeNewGObject mkGObject) $
  liftM castPtr $
  {# call unsafe value_get_object #} gvalue


Output feeding and signal capabilities for VteLite widgets

darcs-hash:20090216172650-ceb9a-79ceb0abc15bb803e962ba1fa84a7a5afca32005.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Button
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- A widget that creates a signal when clicked on
--
module Graphics.UI.Gtk.VteLite (

-- * Types
  VteTerminal,
  VteLiteClass,

-- * Constructors
  vteLiteNew,

-- * Methods
  vteLiteSetFontFromString,
  vteLiteSetMouseAutoHide,
  vteLiteBeginAppOutput,
  vteLiteFinishAppOutput,
  vteLiteFeed,

-- * Signals
  onLineReceived
  ) where

import Control.Monad	(liftM)
import Foreign.ForeignPtr
import Foreign.Ptr

import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
import System.Glib.FFI
import System.Glib.UTFString

{#pointer *VteTerminal foreign newtype #}

class WidgetClass o => VteLiteClass o
toVteLite :: VteLiteClass o => o -> VteTerminal
toVteLite = unsafeCastGObject . toGObject

mkVteLite = VteTerminal
unVteLite (VteTerminal o) = o

instance VteLiteClass VteTerminal
instance ObjectClass VteTerminal
instance WidgetClass VteTerminal
instance GObjectClass VteTerminal where
  toGObject = mkGObject . castForeignPtr . unVteLite
  unsafeCastGObject = mkVteLite . castForeignPtr . unGObject

vteLiteNew :: IO VteTerminal
vteLiteNew =
  makeNewObject mkVteLite $
  liftM (castPtr :: Ptr Widget -> Ptr VteTerminal) $
  {# call unsafe vte_terminal_new #}

vteLiteSetFontFromString terminal font =
  withUTFString font $ \fontPtr ->
  {# call vte_terminal_set_font_from_string #}
    (toVteLite terminal)
    fontPtr

vteLiteSetMouseAutoHide terminal status =
  {# call vte_terminal_set_mouse_autohide #}
    (toVteLite terminal)
    (fromBool status)

vteLiteBeginAppOutput terminal =
  {# call vte_terminal_begin_app_output #}
    (toVteLite terminal)

vteLiteFinishAppOutput terminal =
  {# call vte_terminal_finish_app_output #}
    (toVteLite terminal)

vteLiteFeed terminal input =
  withUTFString input $ \inputPtr ->
  {# call vte_terminal_feed #}
    (toVteLite terminal)
    inputPtr
    (fromIntegral (length input))

onLineReceived :: VteLiteClass t => t
  -> (String -> IO ())
  -> IO (ConnectId t)
onLineReceived = connect_STRING__NONE "line-received" False

-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget Button
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- A widget that creates a signal when clicked on
--
module Graphics.UI.Gtk.VteLite (

-- * Types
  VteTerminal,
--  VteLiteClass,
--  castToVteLite,
--  toVteLite,

-- * Constructors
  vteLiteNew,

-- * Methods
  vteLiteSetFontFromString,
  vteLiteSetMouseAutoHide,
  vteLiteBeginAppOutput,
  vteLiteFinishAppOutput,
--  vteLiteFeed,

-- * Signals
--  onLineReceived
  ) where

import Control.Monad	(liftM)
import Foreign.ForeignPtr
import Foreign.Ptr

import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
import System.Glib.FFI
import System.Glib.UTFString

{#pointer *VteTerminal foreign newtype #}

class WidgetClass o => VteLiteClass o
toVteLite :: VteLiteClass o => o -> VteTerminal
toVteLite = unsafeCastGObject . toGObject

mkVteLite = VteTerminal
unVteLite (VteTerminal o) = o

instance VteLiteClass VteTerminal
instance ObjectClass VteTerminal
instance WidgetClass VteTerminal
instance GObjectClass VteTerminal where
  toGObject = mkGObject . castForeignPtr . unVteLite
  unsafeCastGObject = mkVteLite . castForeignPtr . unGObject

vteLiteNew :: IO VteTerminal
vteLiteNew =
  makeNewObject mkVteLite $
  liftM (castPtr :: Ptr Widget -> Ptr VteTerminal) $
  {# call unsafe vte_terminal_new #}

vteLiteSetFontFromString terminal font =
  withUTFString font $ \fontPtr ->
  {# call vte_terminal_set_font_from_string #}
    (toVteLite terminal)
    fontPtr

vteLiteSetMouseAutoHide terminal status =
  {# call vte_terminal_set_mouse_autohide #}
    (toVteLite terminal)
    (fromBool status)

vteLiteBeginAppOutput terminal =
  {# call vte_terminal_begin_app_output #}
    (toVteLite terminal)

vteLiteFinishAppOutput terminal =
  {# call vte_terminal_finish_app_output #}
    (toVteLite terminal)


pick a better name than "weird"

pick a better name than "weird"


gstreamer: M.S.G.Core.ElementFactory: Control.Monad.>=> not available before ghc 6.8

--  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
    where infixr 8 >=>
          a >=> b = \x -> a x >>= b

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