remove debugging code

remove debugging code

-- | Bindings to GPGMe
--
-- partial bindings to gpgme

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

#include <gpgme.h>
#include <signal.h>

module Bindings where

import           Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as BS
import           Data.Data
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import           Foreign.C
import           Foreign.ForeignPtr
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

import           System.Posix.IO
import           System.Posix.Types

fromEnum' :: (Enum a, Num b) => a -> b
fromEnum' = fromIntegral . fromEnum

toEnum' :: (Enum c, Integral a) => a -> c
toEnum' = toEnum . fromIntegral

fromFlags :: (Enum a, Num b, Data.Bits.Bits b) => [a] -> b
fromFlags = foldr (.|.) 0 . map fromEnum'

toFlags :: (Data.Bits.Bits a, Eq a, Num a, Enum b, Bounded b) =>
           a
        -> [b]
toFlags x = filter (\y -> let y' = fromEnum' y in x .&. y' /= 0)
              [minBound..maxBound]

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

{#pointer gpgme_ctx_t as Ctx foreign newtype#}

instance Show Ctx where
    show _ = "<GpgMe.CTX>"

{#enum gpgme_err_code_t as ErrorCode {underscoreToCase}
       with prefix = "GPG"
       deriving (Show) #}

{#enum gpgme_err_source_t as ErrorSource {underscoreToCase}
       with prefix = "GPG"

       deriving (Show) #}

data Error = Error { errCode :: ErrorCode
                   , errSource :: ErrorSource
                   , errorString :: Text.Text
                   } deriving (Show, Typeable )

noError :: Error
noError = Error ErrNoError ErrSourceUnknown ""

instance Ex.Exception Error

throwError :: CUInt -> IO ()
throwError e' = do
    mbe <- toError e'
    case mbe of
        Nothing -> return ()
        Just e -> Ex.throwIO e

#c
gpgme_err_code_t gpgme_err_code_uninlined (gpgme_error_t err);
gpgme_err_source_t gpgme_err_source_uninlined (gpgme_error_t err);
#endc

toError :: CUInt -> IO (Maybe Error)
toError err = case err of
    0 -> return Nothing
    _ -> Just <$>
         (allocaBytes 256 $ \buff -> do -- We hope that any error message will
                                        -- be less than 256 bytes long
               _ <- {#call strerror_r#} err buff 256
               Error <$> (toEnum . fromIntegral
                          <$> {# call err_code_uninlined #} err)
                     <*> (toEnum . fromIntegral
                          <$> {# call err_source_uninlined #} err)
                     <*> (Text.pack <$> peekCString buff))

checkVersion :: Maybe Text -> IO (Maybe Text)
checkVersion Nothing = Just . Text.pack <$>
                         (peekCString =<< {#call check_version#} nullPtr)
checkVersion (Just txt) = withCString (Text.unpack txt) $ \buf -> do
    _ <- {#call check_version#} buf
    return Nothing

{#enum gpgme_protocol_t as Protocol {underscoreToCase} deriving (Show, Eq)#}
-- gpgme_engine_check_version (gpgme_protocol_t protocol)

foreign import ccall unsafe "&gpgme_release"
    releaseCtx :: FunPtr (Ptr Ctx -> IO ())

mkContext :: Ptr (Ptr Ctx) -> IO Ctx
mkContext p = do
    if p == nullPtr
        then Ex.throw (Ex.AssertionFailed "nullPtr")
        else fmap Ctx $ newForeignPtr releaseCtx  . castPtr =<< peek p

-- withCtx :: Ctx -> (Ptr Ctx -> IO t) -> IO t
-- withCtx x f = withForeignPtr (fromCtx x) f

{#fun new as ctxNew'
   {alloca- `Ctx' mkContext*}
   -> `()' throwError*- #}

-- | Check that version constraint is satisfied and create a new context
ctxNew :: Maybe Text -> IO Ctx
ctxNew minVersion = do
    _ <- checkVersion minVersion
    ctxNew'

{#enum validity_t as Validity {underscoreToCase} deriving (Show) #}
{#enum attr_t as Attr {underscoreToCase} deriving (Show) #}

------------------------------------
-- Keys
------------------------------------

{#pointer gpgme_key_t as Key foreign newtype #}

withKeysArray :: [Key] -> (Ptr (Ptr Key) -> IO b) -> IO b
withKeysArray ks' f = withKeys ks' $ \ksPtrs -> withArray0 nullPtr ksPtrs f
  where
    withKeys []     g = g []
    withKeys (k:ks) g = withKey k $ \kPtr -> withKeys ks (g . (kPtr:))

foreign import ccall "gpgme.h &gpgme_key_unref"
    unrefPtr :: FunPtr (Ptr Key -> IO ())

getKeys :: Ctx
        -> Bool -- ^ Only keys with secret
        -> IO [Key]
getKeys ctx secretOnly = withCtx ctx $ \ctxPtr -> do
    _ <- {#call gpgme_op_keylist_start #} ctxPtr nullPtr (fromEnum' secretOnly)
    alloca $ takeKeys ctxPtr
  where
    takeKeys ctxPtr (buf :: Ptr (Ptr Key)) = do
        err <- toError =<< {#call gpgme_op_keylist_next#} ctxPtr buf
        case err of
            Nothing -> do
                keyPtr <- peek buf
                key <- newForeignPtr unrefPtr keyPtr
                (Key key :) <$> takeKeys ctxPtr buf
            Just e -> case errCode e of
                ErrEof -> return []
                _ -> error "takeKeys"

reserved :: (Ptr a -> t) -> t
reserved f = f nullPtr

reserved0 :: Num a => (a -> t) -> t
reserved0 f = f 0

{#fun key_get_string_attr as ^
   { withKey* `Key'
   , fromEnum' `Attr'
   , reserved- `Ptr()'
   , `Int'
   } -> `Maybe BS.ByteString' toMaybeText* #}

-------------------------------
-- Data Buffers
-------------------------------

newtype DataBuffer = DataBuffer {fromDataBuffer :: Ptr ()}
mkDataBuffer :: Ptr (Ptr ()) -> IO DataBuffer
mkDataBuffer = fmap DataBuffer . peek

withDataBuffer :: DataBuffer -> (Ptr () -> t) -> t
withDataBuffer (DataBuffer buf) f = f buf

toMaybeText :: Ptr CChar -> IO (Maybe BS.ByteString)
toMaybeText ptr = maybePeek BS.packCString ptr

withMaybeText :: Maybe Text -> (Ptr CChar -> IO a) -> IO a
withMaybeText Nothing = ($ nullPtr)
withMaybeText (Just txt) = withCString (Text.unpack txt)

{#fun data_new as ^
   { alloca- `DataBuffer' mkDataBuffer* }
   -> `()' throwError*- #}

peekInt :: (Storable a, Num b, Integral a) => Ptr a -> IO b
peekInt = fmap fromIntegral . peek

{#fun data_release_and_get_mem as ^
   { fromDataBuffer `DataBuffer'
   , alloca- `Int' peekInt*
   } -> `Ptr ()' castPtr #}

getDataBufferBytes :: DataBuffer -> IO BS.ByteString
getDataBufferBytes db = do
    (dt, len) <- dataReleaseAndGetMem db
    res <- if dt == nullPtr then return BS.empty
                            else do
               bs <- BS.packCStringLen (castPtr dt, len)
               {#call free#} dt
               return bs
    return res

{# fun gpgme_op_export_keys as opExportKeys
   { withCtx* `Ctx'
   , withKeysArray* `[Key]'
   , reserved0- `CUInt'
   , fromDataBuffer `DataBuffer'
   } -> `Error' throwError*- #}

data ImportStatus = ImportStatus { isFprint :: BS.ByteString
                                 , isResult :: Maybe Error
                                 , isStatus :: Int -- TODO: convert to flags
                                 } deriving (Show)

importKeyBuffer :: Ctx -> DataBuffer -> IO [ImportStatus]
importKeyBuffer ctx keyBuffer = withCtx ctx $ \ctxPtr ->
                          withDataBuffer keyBuffer $ \keyPtr -> do
    throwError =<< {#call op_import#} ctxPtr keyPtr
    result <- {#call op_import_result #} ctxPtr
    walkImports =<< {#get import_result_t.imports#} result
  where
    walkImports p = if p == nullPtr
                      then return []
                      else do
        is <- ImportStatus <$> (BS.packCString
                                  =<< {#get import_status_t.fpr #} p)
                           <*> (toError =<< {#get import_status_t.result #} p)
                           <*> (fromIntegral <$> {#get import_status_t.status #} p)
        (is:) <$> (walkImports =<< {#get import_status_t.next #} p)

importKeys :: Ctx -> ByteString -> IO [ImportStatus]
importKeys ctx bs = withBSData bs $ importKeyBuffer ctx

exportKeys :: Ctx -> [Key] -> IO BS.ByteString
exportKeys ctx keys = withBSBuffer $ opExportKeys ctx keys

unsafeUseAsCStringLen' :: Num t =>
                          BS.ByteString
                       -> ((Ptr CChar, t) -> IO a)
                       -> IO a
unsafeUseAsCStringLen' bs f =
    BS.unsafeUseAsCStringLen bs $ \(bs', l) -> f (bs', fromIntegral l)

{# fun data_new_from_mem as ^
   { alloca- `DataBuffer' mkDataBuffer*
   , unsafeUseAsCStringLen' * `BS.ByteString'&
   , fromEnum' `Bool'
   } -> `Error' throwError*- #}

{# fun data_release as ^
   { withDataBuffer* `DataBuffer'} -> `()' #}

{# fun set_armor as ^
     { withCtx* `Ctx'
     , fromEnum' `Bool'
     } -> `()' #}

withBSData :: BS.ByteString -> (DataBuffer -> IO c) -> IO c
withBSData bs =
    Ex.bracket (dataNewFromMem bs True)
               dataRelease

withBSBuffer :: (DataBuffer -> IO a) -> IO BS.ByteString
withBSBuffer f =
    Ex.bracketOnError dataNew
                      dataRelease
                      $ \db -> do
                          _ <- f db
                          getDataBufferBytes db

-----------------------------------
-- Signing
-----------------------------------

{#fun signers_clear as ^
    {withCtx* `Ctx'} -> `()'#}

{#fun signers_add as ^
    { withCtx* `Ctx'
    , withKey* `Key'
    } -> `()' throwError* #}

{# enum sig_mode_t as SigMode {underscoreToCase}
       with prefix = "GPGME"
       deriving (Show) #}

{#fun op_sign as ^
    { withCtx* `Ctx'
    , withDataBuffer* `DataBuffer'
    , withDataBuffer* `DataBuffer'
    , fromEnum' `SigMode'
    } -> `()' throwError*- #}
--     exportKey

-- | Sign a text using a private signing key from the GPG keychain
sign :: Ctx
     -> BS.ByteString -- ^ Text to sign
     -> Key -- ^ Signing key to use
     -> SigMode -- ^ Signing mode
     -> IO BS.ByteString
sign ctx plain key mode = withBSData plain $ \plainData ->
                          withBSBuffer $ \outData -> (do
    signersClear ctx
    signersAdd ctx key
    opSign ctx plainData outData mode)
       `Ex.finally` signersClear ctx

{# enum sigsum_t as SigSummary {underscoreToCase} deriving (Bounded, Show)#}
{# enum sig_stat_t as SigStat {underscoreToCase} deriving (Bounded, Show)#}

{#fun op_verify as ^
   { withCtx* `Ctx'
   , withDataBuffer* `DataBuffer' -- sig
   , withDataBuffer* `DataBuffer' -- signed-text
   , withDataBuffer* `DataBuffer' -- plain
   } -> `()' throwError*- #}

data VerifyResult = VerifyResult { summary :: [SigSummary]
                                 , fingerprint :: ByteString
                                 , status :: SigStat
                                 , timestamp :: Integer
                                 , expTimestamp :: Integer
                                 , wrongKeyUsage :: Bool
                                 , pkaTrust :: Int
                                 , chainModel :: Bool
                                 , validity :: Validity
                                 , validityReason :: ErrorCode
                                 } deriving Show

peekVerifyResults :: Ptr () -> IO [VerifyResult]
peekVerifyResults ptr | ptr == nullPtr = return []
                      | otherwise = do
    summary <- toFlags <$> {#get gpgme_signature_t->summary#} ptr
    fingerprint <- BS.packCString =<<{# get gpgme_signature_t->fpr#} ptr
    status' <- gpgme_err_code_uninlined =<< {#get gpgme_signature_t->status#} ptr
    let status = case toEnum' status' of
               ErrNoError -> SigStatGood
               ErrBadSignature -> SigStatBad
               ErrNoPubkey -> SigStatNokey
               ErrNoData -> SigStatNosig
               ErrSigExpired -> SigStatGoodExp
               ErrKeyExpired -> SigStatGoodExpkey
               _ -> SigStatError
    timestamp <- fromIntegral <$> {#get gpgme_signature_t->timestamp#} ptr
    expTimestamp <- fromIntegral <$> {#get gpgme_signature_t->exp_timestamp#} ptr
    wrongKeyUsage <- toEnum' <$> {#get gpgme_signature_t->wrong_key_usage#} ptr
    pkaTrust <- fromIntegral <$> {#get gpgme_signature_t->pka_trust#} ptr
    chainModel <- toEnum' <$> {#get gpgme_signature_t->chain_model #} ptr
    validity <- toEnum' <$> {#get gpgme_signature_t->validity #} ptr
    validityReason <- toEnum' <$> {#get gpgme_signature_t->validity_reason#} ptr
    let res = VerifyResult { summary = summary
                           , fingerprint = fingerprint
                           , status = status
                           , timestamp = timestamp
                           , expTimestamp = expTimestamp
                           , wrongKeyUsage = wrongKeyUsage
                           , pkaTrust = pkaTrust
                           , chainModel = chainModel
                           , validity = validity
                           , validityReason = validityReason
                           }
    next <- {#get gpgme_signature_t->next #} ptr
    nextResult <- peekVerifyResults next
    return (res : nextResult)

verifyResult :: Ctx -> IO [VerifyResult]
verifyResult ctx = withCtx ctx $ \ctxPtr -> do
    res <- {# call gpgme_op_verify_result #} ctxPtr
    peekVerifyResults =<< {#get verify_result_t->signatures#} res

-- | Verify a signature created in 'SigModeDetach' mode
verifyDetach :: Ctx
             -> BS.ByteString -- ^ The source text that the signature pertains to
             -> BS.ByteString -- ^ The signature
             -> IO [VerifyResult]
verifyDetach ctx signedText sig = withBSData signedText $ \stData ->
                                  withBSData sig $ \sigData -> do
    opVerify ctx sigData stData (DataBuffer nullPtr)
    verifyResult ctx

-- | Verify a signature created in 'SigModeNormal' or 'SigModeClear' mode
verify :: Ctx
        -> BS.ByteString -- ^ Text and attached Signature
        -> IO ([VerifyResult], BS.ByteString) -- ^ result and extracted plain text
verify ctx sig = withBSData sig $ \sigData -> do
    plain <- withBSBuffer $ \plainData ->
        opVerify ctx sigData (DataBuffer nullPtr) plainData
    res <- verifyResult ctx
    return (res, plain)

--------------------------------
-- Passphrases
--------------------------------

-- gpgme_error_t (*gpgme_passphrase_cb_t)(void *hook, const char *uid_hint, const char *passphrase_info, int prev_was_bad, int fd)

type PassphraseCallback = Ptr () -- ^ Hook
                        -> Ptr CChar -- ^ Uid Hint
                        -> Ptr CChar -- ^ passphrase info
                        -> CInt -- ^ Was Bad?
                        -> CInt -- ^ fd
                        -> IO CUInt

foreign import ccall "wrapper"
  mkPasswordCallback  :: PassphraseCallback -> IO (FunPtr PassphraseCallback)

setPassphraseCallback :: Ctx
                      -> (String -> String -> Bool -> IO String)
                      -> IO ()
setPassphraseCallback ctx f = do
    let cbFun _ uidHint pInfo bad fd = do
               uidHintString <- peekCString uidHint
               pInfoString <- peekCString pInfo
               out <- f uidHintString pInfoString (bad == 0)
               _ <- fdWrite (Fd fd) (filter (/= '\n') out ++ "\n" )
               return 0
    cb <- mkPasswordCallback cbFun
    withCtx ctx $ \ctxPtr -> {# call set_passphrase_cb #} ctxPtr cb nullPtr

data Engine = Engine { engineProtocol   :: Protocol
                     , engineFilename   :: Maybe String
                     , engineHomeDir    :: Maybe String
                     , engineVersion    :: Maybe String
                     , engineReqVersion :: Maybe String
                     } deriving (Show)

getEngines :: Ctx -> IO [Engine]
getEngines ctx = withCtx ctx $ \ctxPtr ->  do
    goEngines =<< {#call ctx_get_engine_info #} ctxPtr
  where
    goEngines this = if this == nullPtr
                     then return []
                     else do
        engine <- Engine <$> (toEnum' <$> {# get engine_info_t.protocol#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.file_name#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.home_dir#}    this)
                         <*> (peekCSM =<< {#get engine_info_t.version#}     this)
                         <*> (peekCSM =<< {#get engine_info_t.req_version#} this)
        next <- {# get gpgme_engine_info_t.next #} this
        (engine:) <$> goEngines next
    peekCSM cString = if cString == nullPtr
                      then return Nothing
                      else Just <$> peekCString cString

setEngine :: Ctx -> Engine -> IO ()
setEngine ctx eng = withCtx ctx $ \ctxPtr->
                    withMBCString (engineFilename eng) $ \fNamePtr ->
                    withMBCString (engineHomeDir eng)  $ \hDirPtr ->
    throwError =<< {#call ctx_set_engine_info #} ctxPtr
                                                 (fromEnum' $ engineProtocol eng)
                                                 fNamePtr
                                                 hDirPtr
  where
    withMBCString Nothing f = f nullPtr
    withMBCString (Just str) f = withCString str f

{# enum pinentry_mode_t as PinentryMode {underscoreToCase} #}

{# fun set_pinentry_mode as ^
   { withCtx* `Ctx'
   , fromEnum' `PinentryMode'
   } -> `()' throwError*- #}

-------------------------------------------
-- Key Creation ---------------------------
-------------------------------------------
data GenKeyResult = GenKeyResult { genKeyhasPrimary :: Bool
                                 , genKeyhasSubKey :: Bool
                                 , genKeyFingerprint :: Maybe BS.ByteString
                                 } deriving (Show)

genKey :: Ctx -> String -> IO GenKeyResult
genKey ctx params = withCtx ctx $ \ctxPtr ->
                    withCString params $ \paramsPtr -> do
    throwError =<< {#call gpgme_op_genkey#} ctxPtr paramsPtr nullPtr nullPtr
    res <- {#call gpgme_op_genkey_result#} ctxPtr
    prim <- toEnum' <$> {#get gpgme_genkey_result_t.primary#} res
    sub <- toEnum' <$> {#get gpgme_genkey_result_t.sub#} res
    fprint <- maybePeek BS.packCString =<< {#get gpgme_genkey_result_t.fpr#} res
    return $ GenKeyResult prim sub fprint

------------------------------------------
-- Key Deletion --------------------------
------------------------------------------

{# fun gpgme_op_delete as deleteKey
 { withCtx* `Ctx'
 , withKey* `Key'
 , fromEnum' `Bool'
 } -> `()' throwError*- #}

------------------------------------------
-- Key Editing ---------------------------
------------------------------------------

-- gpgme_error_t (*gpgme_edit_cb_t) (void *handle, gpgme_status_code_t status, const char *args, int fd)

{# enum gpgme_status_code_t as StatusCode {underscoreToCase} deriving (Show, Read, Eq, Data, Typeable, Bounded) #}

type EditCallback' = Ptr () -> CInt -> CString -> CInt -> IO CUInt
type EditCallback = StatusCode -> Text -> Fd -> IO Error

foreign import ccall "wrapper"
    mkEditCallback :: EditCallback' -> IO (FunPtr EditCallback')

#c
gpgme_error_t gpgme_err_make_uninlined ( gpgme_err_source_t err_source
                                       , gpgme_err_code_t err_code);
#endc

{# fun gpgme_err_make_uninlined as mkError
   { fromEnum'  `ErrorSource'
   , fromEnum' `ErrorCode'
   }
   -> `CUInt' id #}

editKey :: Ctx -> Key -> EditCallback -> IO ByteString
editKey ctx key callback = do
    let callback' _ scInt cStr fdInt = do
            str <- if (cStr == nullPtr) then return "" else peekCString cStr
            err <- callback (toEnum $ fromIntegral scInt) (Text.pack str)
                            (Fd fdInt)
            mkError (errSource err) (errCode err)
    Ex.bracket (mkEditCallback callback') freeHaskellFunPtr
        $ \cb ->
        withCtx ctx $ \ctxPtr ->
        withKey key $ \keyPtr ->
        withBSBuffer $ \buffer ->
        withDataBuffer buffer $ \bufferPtr ->
        throwError =<< {#call gpgme_op_edit#} ctxPtr keyPtr cb nullPtr bufferPtr

-----------------------------------------
-- Process ------------------------------
-----------------------------------------

{# fun kill as ^
    { fromIntegral `CPid'
    , fromIntegral `Int'
    } -> `Int' fromIntegral #}

-- | Bindings to GPGMe
--
-- partial bindings to gpgme

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}

#include <gpgme.h>
#include <signal.h>

module Bindings where

import           Control.Applicative ((<$>), (<*>))
import qualified Control.Exception as Ex
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as BS
import           Data.Data
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import           Foreign.C
import           Foreign.ForeignPtr
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable

import           System.Posix.IO
import           System.Posix.Types

fromEnum' :: (Enum a, Num b) => a -> b
fromEnum' = fromIntegral . fromEnum

toEnum' :: (Enum c, Integral a) => a -> c
toEnum' = toEnum . fromIntegral

fromFlags :: (Enum a, Num b, Data.Bits.Bits b) => [a] -> b
fromFlags = foldr (.|.) 0 . map fromEnum'

toFlags :: (Data.Bits.Bits a, Eq a, Num a, Enum b, Bounded b) =>
           a
        -> [b]
toFlags x = filter (\y -> let y' = fromEnum' y in x .&. y' /= 0)
              [minBound..maxBound]

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

{#pointer gpgme_ctx_t as Ctx foreign newtype#}

instance Show Ctx where
    show _ = "<GpgMe.CTX>"

{#enum gpgme_err_code_t as ErrorCode {underscoreToCase}
       with prefix = "GPG"
       deriving (Show) #}

{#enum gpgme_err_source_t as ErrorSource {underscoreToCase}
       with prefix = "GPG"

       deriving (Show) #}

data Error = Error { errCode :: ErrorCode
                   , errSource :: ErrorSource
                   , errorString :: Text.Text
                   } deriving (Show, Typeable )

noError :: Error
noError = Error ErrNoError ErrSourceUnknown ""

instance Ex.Exception Error

throwError :: CUInt -> IO ()
throwError e' = do
    mbe <- toError e'
    case mbe of
        Nothing -> return ()
        Just e -> Ex.throwIO e

#c
gpgme_err_code_t gpgme_err_code_uninlined (gpgme_error_t err);
gpgme_err_source_t gpgme_err_source_uninlined (gpgme_error_t err);
#endc

toError :: CUInt -> IO (Maybe Error)
toError err = case err of
    0 -> return Nothing
    _ -> Just <$>
         (allocaBytes 256 $ \buff -> do -- We hope that any error message will
                                        -- be less than 256 bytes long
               _ <- {#call strerror_r#} err buff 256
               Error <$> (toEnum . fromIntegral
                          <$> {# call err_code_uninlined #} err)
                     <*> (toEnum . fromIntegral
                          <$> {# call err_source_uninlined #} err)
                     <*> (Text.pack <$> peekCString buff))

checkVersion :: Maybe Text -> IO (Maybe Text)
checkVersion Nothing = Just . Text.pack <$>
                         (peekCString =<< {#call check_version#} nullPtr)
checkVersion (Just txt) = withCString (Text.unpack txt) $ \buf -> do
    _ <- {#call check_version#} buf
    return Nothing

{#enum gpgme_protocol_t as Protocol {underscoreToCase} deriving (Show, Eq)#}
-- gpgme_engine_check_version (gpgme_protocol_t protocol)

foreign import ccall unsafe "&gpgme_release"
    releaseCtx :: FunPtr (Ptr Ctx -> IO ())

mkContext :: Ptr (Ptr Ctx) -> IO Ctx
mkContext p = do
    if p == nullPtr
        then Ex.throw (Ex.AssertionFailed "nullPtr")
        else fmap Ctx $ newForeignPtr releaseCtx  . castPtr =<< peek p

-- withCtx :: Ctx -> (Ptr Ctx -> IO t) -> IO t
-- withCtx x f = withForeignPtr (fromCtx x) f

{#fun new as ctxNew'
   {alloca- `Ctx' mkContext*}
   -> `()' throwError*- #}

-- | Check that version constraint is satisfied and create a new context
ctxNew :: Maybe Text -> IO Ctx
ctxNew minVersion = do
    _ <- checkVersion minVersion
    ctxNew'

{#enum validity_t as Validity {underscoreToCase} deriving (Show) #}
{#enum attr_t as Attr {underscoreToCase} deriving (Show) #}

------------------------------------
-- Keys
------------------------------------

{#pointer gpgme_key_t as Key foreign newtype #}

withKeysArray :: [Key] -> (Ptr (Ptr Key) -> IO b) -> IO b
withKeysArray ks' f = withKeys ks' $ \ksPtrs -> withArray0 nullPtr ksPtrs f
  where
    withKeys []     g = g []
    withKeys (k:ks) g = withKey k $ \kPtr -> withKeys ks (g . (kPtr:))

foreign import ccall "gpgme.h &gpgme_key_unref"
    unrefPtr :: FunPtr (Ptr Key -> IO ())

getKeys :: Ctx
        -> Bool -- ^ Only keys with secret
        -> IO [Key]
getKeys ctx secretOnly = withCtx ctx $ \ctxPtr -> do
    _ <- {#call gpgme_op_keylist_start #} ctxPtr nullPtr (fromEnum' secretOnly)
    alloca $ takeKeys ctxPtr
  where
    takeKeys ctxPtr (buf :: Ptr (Ptr Key)) = do
        err <- toError =<< {#call gpgme_op_keylist_next#} ctxPtr buf
        case err of
            Nothing -> do
                keyPtr <- peek buf
                key <- newForeignPtr unrefPtr keyPtr
                (Key key :) <$> takeKeys ctxPtr buf
            Just e -> case errCode e of
                ErrEof -> return []
                _ -> error "takeKeys"

reserved :: (Ptr a -> t) -> t
reserved f = f nullPtr

reserved0 :: Num a => (a -> t) -> t
reserved0 f = f 0

{#fun key_get_string_attr as ^
   { withKey* `Key'
   , fromEnum' `Attr'
   , reserved- `Ptr()'
   , `Int'
   } -> `Maybe BS.ByteString' toMaybeText* #}

-------------------------------
-- Data Buffers
-------------------------------

newtype DataBuffer = DataBuffer {fromDataBuffer :: Ptr ()}
mkDataBuffer :: Ptr (Ptr ()) -> IO DataBuffer
mkDataBuffer = fmap DataBuffer . peek

withDataBuffer :: DataBuffer -> (Ptr () -> t) -> t
withDataBuffer (DataBuffer buf) f = f buf

toMaybeText :: Ptr CChar -> IO (Maybe BS.ByteString)
toMaybeText ptr = maybePeek BS.packCString ptr

withMaybeText :: Maybe Text -> (Ptr CChar -> IO a) -> IO a
withMaybeText Nothing = ($ nullPtr)
withMaybeText (Just txt) = withCString (Text.unpack txt)

{#fun data_new as ^
   { alloca- `DataBuffer' mkDataBuffer* }
   -> `()' throwError*- #}

peekInt :: (Storable a, Num b, Integral a) => Ptr a -> IO b
peekInt = fmap fromIntegral . peek

{#fun data_release_and_get_mem as ^
   { fromDataBuffer `DataBuffer'
   , alloca- `Int' peekInt*
   } -> `Ptr ()' castPtr #}

getDataBufferBytes :: DataBuffer -> IO BS.ByteString
getDataBufferBytes db = do
    (dt, len) <- dataReleaseAndGetMem db
    res <- if dt == nullPtr then return BS.empty
                            else do
               bs <- BS.packCStringLen (castPtr dt, len)
               {#call free#} dt
               return bs
    return res

{# fun gpgme_op_export_keys as opExportKeys
   { withCtx* `Ctx'
   , withKeysArray* `[Key]'
   , reserved0- `CUInt'
   , fromDataBuffer `DataBuffer'
   } -> `Error' throwError*- #}

data ImportStatus = ImportStatus { isFprint :: BS.ByteString
                                 , isResult :: Maybe Error
                                 , isStatus :: Int -- TODO: convert to flags
                                 } deriving (Show)

importKeyBuffer :: Ctx -> DataBuffer -> IO [ImportStatus]
importKeyBuffer ctx keyBuffer = withCtx ctx $ \ctxPtr ->
                          withDataBuffer keyBuffer $ \keyPtr -> do
    throwError =<< {#call op_import#} ctxPtr keyPtr
    result <- {#call op_import_result #} ctxPtr
    walkImports =<< {#get import_result_t.imports#} result
  where
    walkImports p = if p == nullPtr
                      then return []
                      else do
        is <- ImportStatus <$> (BS.packCString
                                  =<< {#get import_status_t.fpr #} p)
                           <*> (toError =<< {#get import_status_t.result #} p)
                           <*> (fromIntegral <$> {#get import_status_t.status #} p)
        (is:) <$> (walkImports =<< {#get import_status_t.next #} p)

importKeys :: Ctx -> ByteString -> IO [ImportStatus]
importKeys ctx bs = withBSData bs $ importKeyBuffer ctx

exportKeys :: Ctx -> [Key] -> IO BS.ByteString
exportKeys ctx keys = withBSBuffer $ opExportKeys ctx keys

unsafeUseAsCStringLen' :: Num t =>
                          BS.ByteString
                       -> ((Ptr CChar, t) -> IO a)
                       -> IO a
unsafeUseAsCStringLen' bs f =
    BS.unsafeUseAsCStringLen bs $ \(bs', l) -> f (bs', fromIntegral l)

{# fun data_new_from_mem as ^
   { alloca- `DataBuffer' mkDataBuffer*
   , unsafeUseAsCStringLen' * `BS.ByteString'&
   , fromEnum' `Bool'
   } -> `Error' throwError*- #}

{# fun data_release as ^
   { withDataBuffer* `DataBuffer'} -> `()' #}

{# fun set_armor as ^
     { withCtx* `Ctx'
     , fromEnum' `Bool'
     } -> `()' #}

withBSData :: BS.ByteString -> (DataBuffer -> IO c) -> IO c
withBSData bs =
    Ex.bracket (dataNewFromMem bs True)
               dataRelease

withBSBuffer :: (DataBuffer -> IO a) -> IO BS.ByteString
withBSBuffer f =
    Ex.bracketOnError dataNew
                      dataRelease
                      $ \db -> do
                          _ <- f db
                          getDataBufferBytes db

-----------------------------------
-- Signing
-----------------------------------

{#fun signers_clear as ^
    {withCtx* `Ctx'} -> `()'#}

{#fun signers_add as ^
    { withCtx* `Ctx'
    , withKey* `Key'
    } -> `()' throwError* #}

{# enum sig_mode_t as SigMode {underscoreToCase}
       with prefix = "GPGME"
       deriving (Show) #}

{#fun op_sign as ^
    { withCtx* `Ctx'
    , withDataBuffer* `DataBuffer'
    , withDataBuffer* `DataBuffer'
    , fromEnum' `SigMode'
    } -> `()' throwError*- #}
--     exportKey

-- | Sign a text using a private signing key from the GPG keychain
sign :: Ctx
     -> BS.ByteString -- ^ Text to sign
     -> Key -- ^ Signing key to use
     -> SigMode -- ^ Signing mode
     -> IO BS.ByteString
sign ctx plain key mode = withBSData plain $ \plainData ->
                          withBSBuffer $ \outData -> (do
    signersClear ctx
    signersAdd ctx key
    opSign ctx plainData outData mode)
       `Ex.finally` signersClear ctx

{# enum sigsum_t as SigSummary {underscoreToCase} deriving (Bounded, Show)#}
{# enum sig_stat_t as SigStat {underscoreToCase} deriving (Bounded, Show)#}

{#fun op_verify as ^
   { withCtx* `Ctx'
   , withDataBuffer* `DataBuffer' -- sig
   , withDataBuffer* `DataBuffer' -- signed-text
   , withDataBuffer* `DataBuffer' -- plain
   } -> `()' throwError*- #}

data VerifyResult = VerifyResult { summary :: [SigSummary]
                                 , fingerprint :: ByteString
                                 , status :: SigStat
                                 , timestamp :: Integer
                                 , expTimestamp :: Integer
                                 , wrongKeyUsage :: Bool
                                 , pkaTrust :: Int
                                 , chainModel :: Bool
                                 , validity :: Validity
                                 , validityReason :: ErrorCode
                                 } deriving Show

peekVerifyResults :: Ptr () -> IO [VerifyResult]
peekVerifyResults ptr | ptr == nullPtr = return []
                      | otherwise = do
    summary <- toFlags <$> {#get gpgme_signature_t->summary#} ptr
    fingerprint <- BS.packCString =<<{# get gpgme_signature_t->fpr#} ptr
    status' <- gpgme_err_code_uninlined =<< {#get gpgme_signature_t->status#} ptr
    let status = case toEnum' status' of
               ErrNoError -> SigStatGood
               ErrBadSignature -> SigStatBad
               ErrNoPubkey -> SigStatNokey
               ErrNoData -> SigStatNosig
               ErrSigExpired -> SigStatGoodExp
               ErrKeyExpired -> SigStatGoodExpkey
               _ -> SigStatError
    timestamp <- fromIntegral <$> {#get gpgme_signature_t->timestamp#} ptr
    expTimestamp <- fromIntegral <$> {#get gpgme_signature_t->exp_timestamp#} ptr
    wrongKeyUsage <- toEnum' <$> {#get gpgme_signature_t->wrong_key_usage#} ptr
    pkaTrust <- fromIntegral <$> {#get gpgme_signature_t->pka_trust#} ptr
    chainModel <- toEnum' <$> {#get gpgme_signature_t->chain_model #} ptr
    validity <- toEnum' <$> {#get gpgme_signature_t->validity #} ptr
    validityReason <- toEnum' <$> {#get gpgme_signature_t->validity_reason#} ptr
    let res = VerifyResult { summary = summary
                           , fingerprint = fingerprint
                           , status = status
                           , timestamp = timestamp
                           , expTimestamp = expTimestamp
                           , wrongKeyUsage = wrongKeyUsage
                           , pkaTrust = pkaTrust
                           , chainModel = chainModel
                           , validity = validity
                           , validityReason = validityReason
                           }
    next <- {#get gpgme_signature_t->next #} ptr
    nextResult <- peekVerifyResults next
    return (res : nextResult)

verifyResult :: Ctx -> IO [VerifyResult]
verifyResult ctx = withCtx ctx $ \ctxPtr -> do
    res <- {# call gpgme_op_verify_result #} ctxPtr
    peekVerifyResults =<< {#get verify_result_t->signatures#} res

-- | Verify a signature created in 'SigModeDetach' mode
verifyDetach :: Ctx
             -> BS.ByteString -- ^ The source text that the signature pertains to
             -> BS.ByteString -- ^ The signature
             -> IO [VerifyResult]
verifyDetach ctx signedText sig = withBSData signedText $ \stData ->
                                  withBSData sig $ \sigData -> do
    opVerify ctx sigData stData (DataBuffer nullPtr)
    verifyResult ctx

-- | Verify a signature created in 'SigModeNormal' or 'SigModeClear' mode
verify :: Ctx
        -> BS.ByteString -- ^ Text and attached Signature
        -> IO ([VerifyResult], BS.ByteString) -- ^ result and extracted plain text
verify ctx sig = withBSData sig $ \sigData -> do
    plain <- withBSBuffer $ \plainData ->
        opVerify ctx sigData (DataBuffer nullPtr) plainData
    res <- verifyResult ctx
    return (res, plain)

--------------------------------
-- Passphrases
--------------------------------

-- gpgme_error_t (*gpgme_passphrase_cb_t)(void *hook, const char *uid_hint, const char *passphrase_info, int prev_was_bad, int fd)

type PassphraseCallback = Ptr () -- ^ Hook
                        -> Ptr CChar -- ^ Uid Hint
                        -> Ptr CChar -- ^ passphrase info
                        -> CInt -- ^ Was Bad?
                        -> CInt -- ^ fd
                        -> IO CUInt

foreign import ccall "wrapper"
  mkPasswordCallback  :: PassphraseCallback -> IO (FunPtr PassphraseCallback)

setPassphraseCallback :: Ctx
                      -> (String -> String -> Bool -> IO String)
                      -> IO ()
setPassphraseCallback ctx f = do
    let cbFun _ uidHint pInfo bad fd = do
               uidHintString <- peekCString uidHint
               pInfoString <- peekCString pInfo
               out <- f uidHintString pInfoString (bad == 0)
               _ <- fdWrite (Fd fd) (filter (/= '\n') out ++ "\n" )
               return 0
    cb <- mkPasswordCallback cbFun
    withCtx ctx $ \ctxPtr -> {# call set_passphrase_cb #} ctxPtr cb nullPtr

data Engine = Engine { engineProtocol   :: Protocol
                     , engineFilename   :: Maybe String
                     , engineHomeDir    :: Maybe String
                     , engineVersion    :: Maybe String
                     , engineReqVersion :: Maybe String
                     } deriving (Show)

getEngines :: Ctx -> IO [Engine]
getEngines ctx = withCtx ctx $ \ctxPtr ->  do
    goEngines =<< {#call ctx_get_engine_info #} ctxPtr
  where
    goEngines this = if this == nullPtr
                     then return []
                     else do
        engine <- Engine <$> (toEnum' <$> {# get engine_info_t.protocol#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.file_name#}   this)
                         <*> (peekCSM =<< {#get engine_info_t.home_dir#}    this)
                         <*> (peekCSM =<< {#get engine_info_t.version#}     this)
                         <*> (peekCSM =<< {#get engine_info_t.req_version#} this)
        next <- {# get gpgme_engine_info_t.next #} this
        (engine:) <$> goEngines next
    peekCSM cString = if cString == nullPtr
                      then return Nothing
                      else Just <$> peekCString cString

setEngine :: Ctx -> Engine -> IO ()
setEngine ctx eng = withCtx ctx $ \ctxPtr->
                    withMBCString (engineFilename eng) $ \fNamePtr ->
                    withMBCString (engineHomeDir eng)  $ \hDirPtr ->
    throwError =<< {#call ctx_set_engine_info #} ctxPtr
                                                 (fromEnum' $ engineProtocol eng)
                                                 fNamePtr
                                                 hDirPtr
  where
    withMBCString Nothing f = f nullPtr
    withMBCString (Just str) f = withCString str f

{# enum pinentry_mode_t as PinentryMode {underscoreToCase} #}

{# fun set_pinentry_mode as ^
   { withCtx* `Ctx'
   , fromEnum' `PinentryMode'
   } -> `()' throwError*- #}

-------------------------------------------
-- Key Creation ---------------------------
-------------------------------------------
data GenKeyResult = GenKeyResult { genKeyhasPrimary :: Bool
                                 , genKeyhasSubKey :: Bool
                                 , genKeyFingerprint :: Maybe BS.ByteString
                                 } deriving (Show)

genKey :: Ctx -> String -> IO GenKeyResult
genKey ctx params = withCtx ctx $ \ctxPtr ->
                    withCString params $ \paramsPtr -> do
    putStrLn "starting key genearion"
    throwError =<< {#call gpgme_op_genkey#} ctxPtr paramsPtr nullPtr nullPtr
    putStrLn "retrieving result"
    res <- {#call gpgme_op_genkey_result#} ctxPtr
    putStrLn "Extracting result data"
    prim <- toEnum' <$> {#get gpgme_genkey_result_t.primary#} res
    sub <- toEnum' <$> {#get gpgme_genkey_result_t.sub#} res
    fprint <- maybePeek BS.packCString =<< {#get gpgme_genkey_result_t.fpr#} res
    return $ GenKeyResult prim sub fprint

------------------------------------------
-- Key Deletion --------------------------
------------------------------------------

{# fun gpgme_op_delete as deleteKey
 { withCtx* `Ctx'
 , withKey* `Key'
 , fromEnum' `Bool'
 } -> `()' throwError*- #}

------------------------------------------
-- Key Editing ---------------------------
------------------------------------------

-- gpgme_error_t (*gpgme_edit_cb_t) (void *handle, gpgme_status_code_t status, const char *args, int fd)

{# enum gpgme_status_code_t as StatusCode {underscoreToCase} deriving (Show, Read, Eq, Data, Typeable, Bounded) #}

type EditCallback' = Ptr () -> CInt -> CString -> CInt -> IO CUInt
type EditCallback = StatusCode -> Text -> Fd -> IO Error

foreign import ccall "wrapper"
    mkEditCallback :: EditCallback' -> IO (FunPtr EditCallback')

#c
gpgme_error_t gpgme_err_make_uninlined ( gpgme_err_source_t err_source
                                       , gpgme_err_code_t err_code);
#endc

{# fun gpgme_err_make_uninlined as mkError
   { fromEnum'  `ErrorSource'
   , fromEnum' `ErrorCode'
   }
   -> `CUInt' id #}

editKey :: Ctx -> Key -> EditCallback -> IO ByteString
editKey ctx key callback = do
    let callback' _ scInt cStr fdInt = do
            str <- if (cStr == nullPtr) then return "" else peekCString cStr
            err <- callback (toEnum $ fromIntegral scInt) (Text.pack str)
                            (Fd fdInt)
            mkError (errSource err) (errCode err)
    Ex.bracket (mkEditCallback callback') freeHaskellFunPtr
        $ \cb ->
        withCtx ctx $ \ctxPtr ->
        withKey key $ \keyPtr ->
        withBSBuffer $ \buffer ->
        withDataBuffer buffer $ \bufferPtr ->
        throwError =<< {#call gpgme_op_edit#} ctxPtr keyPtr cb nullPtr bufferPtr

-----------------------------------------
-- Process ------------------------------
-----------------------------------------

{# fun kill as ^
    { fromIntegral `CPid'
    , fromIntegral `Int'
    } -> `Int' fromIntegral #}


Use 'SourceBufferClass buffer => buffer' replace 'SourceBuffer' as function argument.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin, Andy Stewart
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
-- * Types
  SourceBuffer,
  SourceBufferClass,

-- * Methods
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetHighlightSyntax,
  sourceBufferGetHighlightSyntax,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetHighlightMatchingBrackets,
  sourceBufferGetHighlightMatchingBrackets,
  sourceBufferSetStyleScheme,
  sourceBufferGetStyleScheme,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferGetCanUndo,
  sourceBufferGetCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateSourceMark,
  sourceBufferGetSourceMarksAtLine,
  sourceBufferGetSourceMarksAtIter,
  sourceBufferRemoveSourceMarks,
  sourceBufferForwardIterToSourceMark,
  sourceBufferBackwardIterToSourceMark,
  sourceBufferEnsureHighlight,

-- * Attributes
  sourceBufferCanRedo,
  sourceBufferCanUndo,
  sourceBufferHighlightMatchingBrackets,
  sourceBufferHighlightSyntax,
  sourceBufferLanguage,
  sourceBufferSourceStyleScheme,
  sourceBufferMaxUndoLevels,

-- * Signals
  sourceBufferHighlightUpdated,
  sourceBufferRedoSignal,
  sourceBufferUndoSignal,
  sourceBufferSourceMarkUpdated,
  ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GList
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

{#import Graphics.UI.Gtk.SourceView.SourceMark#}

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

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'TextTagTable'.
--
sourceBufferNew :: Maybe TextTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (TextTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- | Controls whether syntax is highlighted in the buffer. If highlight is 'True', the text will be
-- highlighted according to the syntax patterns specified in the language set with
-- 'sourceBufferSetLanguage'. If highlight is 'False', syntax highlighting is disabled and all the
-- 'TextTag' objects that have been added by the syntax highlighting engine are removed from the
-- buffer.
sourceBufferSetHighlightSyntax :: SourceBufferClass buffer => buffer  -- ^ @buffer@    a 'SourceBuffer'.
                               -> Bool  -- ^ @highlight@ 'True' to enable syntax highlighting, 'False' to disable it.
                               -> IO ()
sourceBufferSetHighlightSyntax sb newVal =
  {#call unsafe source_buffer_set_highlight_syntax#}
    (toSourceBuffer sb)
    (fromBool newVal)

-- | Determines whether syntax highlighting is activated in the source buffer.
sourceBufferGetHighlightSyntax :: SourceBufferClass buffer => buffer
                               -> IO Bool  -- ^ returns 'True' if syntax highlighting is enabled, 'False' otherwise.
sourceBufferGetHighlightSyntax sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_syntax#}
    (toSourceBuffer sb)

-- | Associate a 'SourceLanguage' with the source buffer. If language is not-'Nothing' and syntax
-- highlighting is enabled (see 'sourceBufferSetHighlightSyntax', the syntax patterns defined
-- in language will be used to highlight the text contained in the buffer. If language is 'Nothing', the
-- text contained in the buffer is not highlighted.
sourceBufferSetLanguage :: SourceBufferClass buffer => buffer
                        -> Maybe SourceLanguage  -- ^ @language@ a 'SourceLanguage' to set, or 'Nothing'.
                        -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#}
    (toSourceBuffer sb)
    (fromMaybe (SourceLanguage nullForeignPtr) lang)

-- | Returns the 'SourceLanguage' associated with the buffer, see 'sourceBufferSetLanguage'.
sourceBufferGetLanguage :: SourceBufferClass buffer => buffer
                        -> IO (Maybe SourceLanguage) -- ^ returns 'SourceLanguage' associated with the buffer, or 'Nothing'.
sourceBufferGetLanguage sb =
  maybeNull (makeNewGObject mkSourceLanguage) $
  {#call unsafe source_buffer_get_language#} (toSourceBuffer sb)

-- | Controls the bracket match highlighting function in the buffer. If activated, when you position your
-- cursor over a bracket character (a parenthesis, a square bracket, etc.) the matching opening or
-- closing bracket character will be highlighted. You can specify the style with the
-- 'sourceBufferSetBracketMatchStyle' function.
sourceBufferSetHighlightMatchingBrackets :: SourceBufferClass buffer => buffer
                                         -> Bool  -- ^ @highlight@ 'True' if you want matching brackets highlighted.
                                         -> IO ()
sourceBufferSetHighlightMatchingBrackets sb newVal =
  {#call unsafe source_buffer_set_highlight_matching_brackets#} (toSourceBuffer sb) (fromBool newVal)

-- | Determines whether bracket match highlighting is activated for the source buffer.
sourceBufferGetHighlightMatchingBrackets :: SourceBufferClass buffer => buffer
                                         -> IO Bool  -- ^ returns 'True' if the source buffer will highlight matching brackets.
sourceBufferGetHighlightMatchingBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_matching_brackets#} (toSourceBuffer sb)

-- | Sets style scheme used by the buffer. If scheme is 'Nothing' no style scheme is used.
sourceBufferSetStyleScheme :: SourceBufferClass buffer => buffer
                           -> Maybe SourceStyleScheme  -- ^ @scheme@ style scheme.
                           -> IO ()
sourceBufferSetStyleScheme sb scheme =
    {#call unsafe source_buffer_set_style_scheme#}
      (toSourceBuffer sb)
      (fromMaybe (SourceStyleScheme nullForeignPtr) scheme)

-- | Returns the 'SourceStyleScheme' currently used in buffer.
sourceBufferGetStyleScheme :: SourceBufferClass buffer => buffer
                           -> IO (Maybe SourceStyleScheme) -- ^ returns the 'SourceStyleScheme' set by 'sourceBufferSetStyleScheme', or 'Nothing'.
sourceBufferGetStyleScheme sb =
    maybeNull (makeNewGObject mkSourceStyleScheme) $
    {#call unsafe source_buffer_get_style_scheme#} (toSourceBuffer sb)

-- | Sets the number of undo levels for user actions the buffer will track. If the number of user actions
-- exceeds the limit set by this function, older actions will be discarded.
--
-- If @maxUndoLevels@ is -1, no limit is set.
--
-- A new action is started whenever the function 'textBufferBeginUserAction' is called. In
-- general, this happens whenever the user presses any key which modifies the buffer, but the undo
-- manager will try to merge similar consecutive actions, such as multiple character insertions into
-- one action. But, inserting a newline does start a new action.
sourceBufferSetMaxUndoLevels :: SourceBufferClass buffer => buffer
                             -> Int  -- ^ @maxUndoLevels@ the desired maximum number of undo levels.
                             -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} (toSourceBuffer sb) (fromIntegral newVal)

-- | Determines the number of undo levels the buffer will track for buffer edits.
sourceBufferGetMaxUndoLevels :: SourceBufferClass buffer => buffer
                             -> IO Int -- ^ returns the maximum number of possible undo levels or -1 if no limit is set.
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} (toSourceBuffer sb)

-- | Determines whether a source buffer can undo the last action.
sourceBufferGetCanUndo :: SourceBufferClass buffer => buffer
                       -> IO Bool -- ^ returns 'True' if it's possible to undo the last action.
sourceBufferGetCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} (toSourceBuffer sb)

-- | Determines whether a source buffer can redo the last action (i.e. if the last operation was an
-- undo).
sourceBufferGetCanRedo :: SourceBufferClass buffer => buffer
                       -> IO Bool -- ^ returns 'True' if a redo is possible.
sourceBufferGetCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} (toSourceBuffer sb)

-- | Undoes the last user action which modified the buffer. Use 'sourceBufferCanUndo' to check
-- whether a call to this function will have any effect.
--
-- Actions are defined as groups of operations between a call to 'textBufferBeginUserAction'
-- and 'textBufferEndUserAction' on the
-- same line.
sourceBufferUndo :: SourceBufferClass buffer => buffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} (toSourceBuffer sb)

-- | Redoes the last undo operation. Use 'sourceBufferCanRedo' to check whether a call to this
-- function will have any effect.
sourceBufferRedo :: SourceBufferClass buffer => buffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} (toSourceBuffer sb)

-- | Marks the beginning of a not undoable action on the buffer, disabling the undo manager. Typically
-- you would call this function before initially setting the contents of the buffer (e.g. when loading
-- a file in a text editor).
--
-- You may nest 'sourceBufferBeginNotUndoableAction' /
-- 'sourceBufferEndNotUndoableAction' blocks.
sourceBufferBeginNotUndoableAction :: SourceBufferClass buffer => buffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} (toSourceBuffer sb)

-- | Marks the end of a not undoable action on the buffer. When the last not undoable block is closed
-- through the call to this function, the list of undo actions is cleared and the undo manager is
-- re-enabled.
sourceBufferEndNotUndoableAction :: SourceBufferClass buffer => buffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} (toSourceBuffer sb)

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateSourceMark :: SourceBufferClass buffer => buffer -- the buffer
                         -> Maybe String -- the name of the mark
                         -> String -- the category of the mark
                         -> TextIter -> IO SourceMark
sourceBufferCreateSourceMark sb name category iter =
  makeNewGObject mkSourceMark $
  maybeWith withCString name       $ \strPtr1 ->
  withCString category $ \strPtr2 ->
  {#call source_buffer_create_source_mark#} (toSourceBuffer sb) strPtr1 strPtr2 iter

-- | Returns the list of marks of the given category at line. If category is empty, all marks at line are
-- returned.
sourceBufferGetSourceMarksAtLine :: SourceBufferClass buffer => buffer  -- ^ @buffer@   a 'SourceBuffer'.
                                 -> Int -- ^ @line@     a line number.
                                 -> String -- ^ @category@ category to search for or empty
                                 -> IO [SourceMark]
sourceBufferGetSourceMarksAtLine buffer line category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_get_source_marks_at_line #}
    (toSourceBuffer buffer)
    (fromIntegral line)
    categoryPtr
  >>= readGSList
  >>= mapM (\markPtr -> makeNewGObject mkSourceMark (return markPtr))

-- | Returns the list of marks of the given category at iter. If category is empty it returns all marks at
-- iter.
sourceBufferGetSourceMarksAtIter :: SourceBufferClass buffer => buffer -- ^ @buffer@   a 'SourceBuffer'.
                                 -> TextIter -- ^ @iter@     an iterator.
                                 -> String -- ^ @category@ category to search for or empty
                                 -> IO [SourceMark]
sourceBufferGetSourceMarksAtIter buffer iter category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_get_source_marks_at_iter #}
    (toSourceBuffer buffer)
    iter
    categoryPtr
  >>= readGSList
  >>= mapM (\markPtr -> makeNewGObject mkSourceMark (return markPtr))

-- | Remove all marks of category between start and end from the buffer. If category is empty, all marks
-- in the range will be removed.
sourceBufferRemoveSourceMarks :: SourceBufferClass buffer => buffer -- ^ @buffer@   a 'SourceBuffer'.
                              -> TextIter -- ^ @start@    a 'TextIter'
                              -> TextIter -- ^ @end@      a 'TextIter'
                              -> String -- ^ @category@ category to search for or empty
                              -> IO ()
sourceBufferRemoveSourceMarks buffer start end category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_remove_source_marks #}
     (toSourceBuffer buffer)
     start
     end
     categoryPtr

-- | Moves iter to the position of the next 'SourceMark' of the given category. Returns 'True' if iter was
-- moved. If category is empty, the next source mark can be of any category.
sourceBufferForwardIterToSourceMark :: SourceBufferClass buffer => buffer -- ^ @buffer@   a 'SourceBuffer'.
                                    -> TextIter -- ^ @iter@     an iterator.
                                    -> String -- ^ @category@ category to search for or emtpy
                                    -> IO Bool -- ^ returns  whether iter moved.
sourceBufferForwardIterToSourceMark buffer iter category =
  liftM toBool $
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_forward_iter_to_source_mark #}
    (toSourceBuffer buffer)
    iter
    categoryPtr

-- | Moves iter to the position of the previous 'SourceMark' of the given category. Returns 'True' if iter
-- was moved. If category is empty, the previous source mark can be of any category.
sourceBufferBackwardIterToSourceMark :: SourceBufferClass buffer => buffer  -- ^ @buffer@   a 'SourceBuffer'.
                                     -> TextIter -- ^ @iter@     an iterator.
                                     -> String -- ^ @category@ category to search for or emtpy
                                     -> IO Bool -- ^ returns  whether iter moved.
sourceBufferBackwardIterToSourceMark buffer iter category =
  liftM toBool $
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_backward_iter_to_source_mark #}
    (toSourceBuffer buffer)
    iter
    categoryPtr

-- | Forces buffer to analyze and highlight the given area synchronously.
--
-- Note
--
-- This is a potentially slow operation and should be used only when you need to make sure that some
-- text not currently visible is highlighted, for instance before printing.
sourceBufferEnsureHighlight :: SourceBufferClass buffer => buffer
                            -> TextIter  -- ^ @start@  start of the area to highlight.
                            -> TextIter  -- ^ @end@    end of the area to highlight.
                            -> IO ()
sourceBufferEnsureHighlight sb start end =
    {#call source_buffer_ensure_highlight#} (toSourceBuffer sb) start end

-- | Whether Redo operation is possible.
--
-- Default value: 'False'
--
sourceBufferCanRedo :: SourceBufferClass buffer => ReadAttr buffer Bool
sourceBufferCanRedo = readAttrFromBoolProperty "can-redo"

-- | Whether Undo operation is possible.
--
-- Default value: 'False'
sourceBufferCanUndo :: SourceBufferClass buffer => ReadAttr buffer Bool
sourceBufferCanUndo = readAttrFromBoolProperty "can-undo"

-- | Whether to highlight matching brackets in the buffer.
--
-- Default value: 'True'
--
sourceBufferHighlightMatchingBrackets :: SourceBufferClass buffer => Attr buffer Bool
sourceBufferHighlightMatchingBrackets = newAttrFromBoolProperty "highlight-matching-brackets"

-- | Whether to highlight syntax in the buffer.
--
-- Default value: 'True'
--
sourceBufferHighlightSyntax :: SourceBufferClass buffer => Attr buffer Bool
sourceBufferHighlightSyntax = newAttrFromBoolProperty "highlight-matching-brackets"

-- | Language object to get highlighting patterns from.
--
sourceBufferLanguage :: SourceBufferClass buffer => Attr buffer (Maybe SourceLanguage)
sourceBufferLanguage = newAttrFromMaybeObjectProperty "language" gTypeSourceLanguage

-- | Number of undo levels for the buffer. -1 means no limit. This property will only affect the default
-- undo manager.
--
-- Allowed values: >= GMaxulong
--
-- Default value: 1000
--
sourceBufferMaxUndoLevels :: SourceBufferClass buffer => Attr buffer Int
sourceBufferMaxUndoLevels = newAttrFromIntProperty "max-undo-levels"

-- | Style scheme. It contains styles for syntax highlighting, optionally foreground, background, cursor
-- color, current line color, and matching brackets style.
--
sourceBufferSourceStyleScheme :: SourceBufferClass buffer => Attr buffer (Maybe SourceStyleScheme)
sourceBufferSourceStyleScheme = newAttrFromMaybeObjectProperty "style-scheme" gTypeSourceStyleScheme

-- |
--
sourceBufferHighlightUpdated :: SourceBufferClass buffer => Signal buffer (TextIter -> TextIter -> IO ())
sourceBufferHighlightUpdated = Signal $ connect_BOXED_BOXED__NONE "highlight-updated" mkTextIterCopy mkTextIterCopy

-- |
--
sourceBufferRedoSignal :: SourceBufferClass buffer => Signal buffer (IO ())
sourceBufferRedoSignal = Signal $ connect_NONE__NONE "redo"

-- |
--
sourceBufferUndoSignal :: SourceBufferClass buffer => Signal buffer (IO ())
sourceBufferUndoSignal = Signal $ connect_NONE__NONE "undo"

-- | The 'sourceBufferMarkUpdated' signal is emitted each time a mark is added to, moved or removed from the
-- buffer.
--
sourceBufferSourceMarkUpdated :: SourceBufferClass buffer => Signal buffer (TextMark -> IO ())
sourceBufferSourceMarkUpdated = Signal $ connect_OBJECT__NONE "source-mark-updated"

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) SourceBuffer
--
--  Author : Peter Gavin, Andy Stewart
--  derived from sourceview bindings by Axel Simon and Duncan Coutts
--
--  Created: 18 December 2008
--
--  Copyright (C) 2003-2008 Peter Gavin, Duncan Coutts, Axel Simon
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceBuffer (
-- * Types
  SourceBuffer,
  SourceBufferClass,

-- * Methods
  castToSourceBuffer,
  sourceBufferNew,
  sourceBufferNewWithLanguage,
  sourceBufferSetHighlightSyntax,
  sourceBufferGetHighlightSyntax,
  sourceBufferSetLanguage,
  sourceBufferGetLanguage,
  sourceBufferSetHighlightMatchingBrackets,
  sourceBufferGetHighlightMatchingBrackets,
  sourceBufferSetStyleScheme,
  sourceBufferGetStyleScheme,
  sourceBufferSetMaxUndoLevels,
  sourceBufferGetMaxUndoLevels,
  sourceBufferGetCanUndo,
  sourceBufferGetCanRedo,
  sourceBufferUndo,
  sourceBufferRedo,
  sourceBufferBeginNotUndoableAction,
  sourceBufferEndNotUndoableAction,
  sourceBufferCreateSourceMark,
  sourceBufferGetSourceMarksAtLine,
  sourceBufferGetSourceMarksAtIter,
  sourceBufferRemoveSourceMarks,
  sourceBufferForwardIterToSourceMark,
  sourceBufferBackwardIterToSourceMark,
  sourceBufferEnsureHighlight,

-- * Attributes
  sourceBufferCanRedo,
  sourceBufferCanUndo,
  sourceBufferHighlightMatchingBrackets,
  sourceBufferHighlightSyntax,
  sourceBufferLanguage,
  sourceBufferSourceStyleScheme,
  sourceBufferMaxUndoLevels,

-- * Signals
  sourceBufferHighlightUpdated,
  sourceBufferRedoSignal,
  sourceBufferUndoSignal,
  sourceBufferSourceMarkUpdated,
  ) where

import Control.Monad	(liftM)
import Data.Maybe    (fromMaybe)

import System.Glib.FFI
import System.Glib.GList
import System.Glib.GObject              (constructNewGObject,
					 makeNewGObject)
{#import System.Glib.Properties#}
import System.Glib.Attributes
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.SourceView.Types#}
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.Multiline.TextIter#}

{#import Graphics.UI.Gtk.SourceView.SourceMark#}

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

-- methods

-- | Create a new 'SourceBuffer', possibly
-- taking a 'TextTagTable'.
--
sourceBufferNew :: Maybe TextTagTable -> IO SourceBuffer
sourceBufferNew tt = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new#}
  (fromMaybe (TextTagTable nullForeignPtr) tt)

-- | Create a new 'SourceBuffer'
-- with a 'SourceLanguage'.
--
sourceBufferNewWithLanguage :: SourceLanguage -> IO SourceBuffer
sourceBufferNewWithLanguage lang = constructNewGObject mkSourceBuffer $
  {#call unsafe source_buffer_new_with_language#} lang

-- | Controls whether syntax is highlighted in the buffer. If highlight is 'True', the text will be
-- highlighted according to the syntax patterns specified in the language set with
-- 'sourceBufferSetLanguage'. If highlight is 'False', syntax highlighting is disabled and all the
-- 'TextTag' objects that have been added by the syntax highlighting engine are removed from the
-- buffer.
sourceBufferSetHighlightSyntax :: SourceBuffer  -- ^ @buffer@    a 'SourceBuffer'.
                               -> Bool  -- ^ @highlight@ 'True' to enable syntax highlighting, 'False' to disable it.
                               -> IO ()
sourceBufferSetHighlightSyntax sb newVal =
  {#call unsafe source_buffer_set_highlight_syntax#} sb (fromBool newVal)

-- | Determines whether syntax highlighting is activated in the source buffer.
sourceBufferGetHighlightSyntax :: SourceBuffer
                               -> IO Bool  -- ^ returns 'True' if syntax highlighting is enabled, 'False' otherwise.
sourceBufferGetHighlightSyntax sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_syntax#} sb

-- | Associate a 'SourceLanguage' with the source buffer. If language is not-'Nothing' and syntax
-- highlighting is enabled (see 'sourceBufferSetHighlightSyntax', the syntax patterns defined
-- in language will be used to highlight the text contained in the buffer. If language is 'Nothing', the
-- text contained in the buffer is not highlighted.
sourceBufferSetLanguage :: SourceBuffer
                        -> Maybe SourceLanguage  -- ^ @language@ a 'SourceLanguage' to set, or 'Nothing'.
                        -> IO ()
sourceBufferSetLanguage sb lang =
  {#call unsafe source_buffer_set_language#}
    sb
    (fromMaybe (SourceLanguage nullForeignPtr) lang)

-- | Returns the 'SourceLanguage' associated with the buffer, see 'sourceBufferSetLanguage'.
sourceBufferGetLanguage :: SourceBuffer
                        -> IO (Maybe SourceLanguage) -- ^ returns 'SourceLanguage' associated with the buffer, or 'Nothing'.
sourceBufferGetLanguage sb =
  maybeNull (makeNewGObject mkSourceLanguage) $
  {#call unsafe source_buffer_get_language#} sb

-- | Controls the bracket match highlighting function in the buffer. If activated, when you position your
-- cursor over a bracket character (a parenthesis, a square bracket, etc.) the matching opening or
-- closing bracket character will be highlighted. You can specify the style with the
-- 'sourceBufferSetBracketMatchStyle' function.
sourceBufferSetHighlightMatchingBrackets :: SourceBuffer
                                         -> Bool  -- ^ @highlight@ 'True' if you want matching brackets highlighted.
                                         -> IO ()
sourceBufferSetHighlightMatchingBrackets sb newVal =
  {#call unsafe source_buffer_set_highlight_matching_brackets#} sb (fromBool newVal)

-- | Determines whether bracket match highlighting is activated for the source buffer.
sourceBufferGetHighlightMatchingBrackets :: SourceBuffer
                                         -> IO Bool  -- ^ returns 'True' if the source buffer will highlight matching brackets.
sourceBufferGetHighlightMatchingBrackets sb = liftM toBool $
  {#call unsafe source_buffer_get_highlight_matching_brackets#} sb

-- | Sets style scheme used by the buffer. If scheme is 'Nothing' no style scheme is used.
sourceBufferSetStyleScheme :: SourceBuffer
                           -> Maybe SourceStyleScheme  -- ^ @scheme@ style scheme.
                           -> IO ()
sourceBufferSetStyleScheme sb scheme =
    {#call unsafe source_buffer_set_style_scheme#}
      sb
      (fromMaybe (SourceStyleScheme nullForeignPtr) scheme)

-- | Returns the 'SourceStyleScheme' currently used in buffer.
sourceBufferGetStyleScheme :: SourceBuffer
                           -> IO (Maybe SourceStyleScheme) -- ^ returns the 'SourceStyleScheme' set by 'sourceBufferSetStyleScheme', or 'Nothing'.
sourceBufferGetStyleScheme sb =
    maybeNull (makeNewGObject mkSourceStyleScheme) $
    {#call unsafe source_buffer_get_style_scheme#} sb

-- | Sets the number of undo levels for user actions the buffer will track. If the number of user actions
-- exceeds the limit set by this function, older actions will be discarded.
--
-- If @maxUndoLevels@ is -1, no limit is set.
--
-- A new action is started whenever the function 'textBufferBeginUserAction' is called. In
-- general, this happens whenever the user presses any key which modifies the buffer, but the undo
-- manager will try to merge similar consecutive actions, such as multiple character insertions into
-- one action. But, inserting a newline does start a new action.
sourceBufferSetMaxUndoLevels :: SourceBuffer
                             -> Int  -- ^ @maxUndoLevels@ the desired maximum number of undo levels.
                             -> IO ()
sourceBufferSetMaxUndoLevels sb newVal =
  {#call unsafe source_buffer_set_max_undo_levels#} sb (fromIntegral newVal)

-- | Determines the number of undo levels the buffer will track for buffer edits.
sourceBufferGetMaxUndoLevels :: SourceBuffer
                             -> IO Int -- ^ returns the maximum number of possible undo levels or -1 if no limit is set.
sourceBufferGetMaxUndoLevels sb = liftM fromIntegral $
  {#call unsafe source_buffer_get_max_undo_levels#} sb

-- | Determines whether a source buffer can undo the last action.
sourceBufferGetCanUndo :: SourceBuffer
                       -> IO Bool -- ^ returns 'True' if it's possible to undo the last action.
sourceBufferGetCanUndo sb = liftM toBool $
  {#call unsafe source_buffer_can_undo#} sb

-- | Determines whether a source buffer can redo the last action (i.e. if the last operation was an
-- undo).
sourceBufferGetCanRedo :: SourceBuffer
                       -> IO Bool -- ^ returns 'True' if a redo is possible.
sourceBufferGetCanRedo sb = liftM toBool $
  {#call unsafe source_buffer_can_redo#} sb

-- | Undoes the last user action which modified the buffer. Use 'sourceBufferCanUndo' to check
-- whether a call to this function will have any effect.
--
-- Actions are defined as groups of operations between a call to 'textBufferBeginUserAction'
-- and 'textBufferEndUserAction' on the
-- same line.
sourceBufferUndo :: SourceBuffer -> IO ()
sourceBufferUndo sb =
  {#call source_buffer_undo#} sb

-- | Redoes the last undo operation. Use 'sourceBufferCanRedo' to check whether a call to this
-- function will have any effect.
sourceBufferRedo :: SourceBuffer -> IO ()
sourceBufferRedo sb =
  {#call source_buffer_redo#} sb

-- | Marks the beginning of a not undoable action on the buffer, disabling the undo manager. Typically
-- you would call this function before initially setting the contents of the buffer (e.g. when loading
-- a file in a text editor).
--
-- You may nest 'sourceBufferBeginNotUndoableAction' /
-- 'sourceBufferEndNotUndoableAction' blocks.
sourceBufferBeginNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferBeginNotUndoableAction sb =
  {#call source_buffer_begin_not_undoable_action#} sb

-- | Marks the end of a not undoable action on the buffer. When the last not undoable block is closed
-- through the call to this function, the list of undo actions is cleared and the undo manager is
-- re-enabled.
sourceBufferEndNotUndoableAction :: SourceBuffer -> IO ()
sourceBufferEndNotUndoableAction sb =
  {#call source_buffer_end_not_undoable_action#} sb

-- | Creates a marker in the buffer of the given type.
--
-- *  A marker is
--    semantically very similar to a 'Graphics.UI.Gtk.Multiline.TextMark',
--    except it has a type
--    which is used by the 'SourceView' displaying the buffer to show a
--    pixmap on the left margin, at the line the marker is in.  Because
--    of this, a marker is generally associated to a line and not a
--    character position.  Markers are also accessible through a position
--    or range in the buffer.
--
-- *  Markers are implemented using 'Graphics.UI.Gtk.Multiline.TextMark',
--    so all characteristics
--    and restrictions to marks apply to markers too.  These includes
--    life cycle issues and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkSet'
--    and 'Graphics.UI.Gtk.Multiline.TextMark.onMarkDeleted' signal
--    emissions.
--
-- *  Like a 'Graphics.UI.Gtk.Multiline.TextMark', a 'SourceMarker'
--    can be anonymous if the
--    passed name is @Nothing@.  Also, the buffer owns the markers so you
--    shouldn't unreference it.

sourceBufferCreateSourceMark :: SourceBuffer -- the buffer
                         -> Maybe String -- the name of the mark
                         -> String -- the category of the mark
                         -> TextIter -> IO SourceMark
sourceBufferCreateSourceMark sb name category iter =
  makeNewGObject mkSourceMark $
  maybeWith withCString name       $ \strPtr1 ->
  withCString category $ \strPtr2 ->
  {#call source_buffer_create_source_mark#} sb strPtr1 strPtr2 iter

-- | Returns the list of marks of the given category at line. If category is empty, all marks at line are
-- returned.
sourceBufferGetSourceMarksAtLine :: SourceBuffer  -- ^ @buffer@   a 'SourceBuffer'.
                                 -> Int -- ^ @line@     a line number.
                                 -> String -- ^ @category@ category to search for or empty
                                 -> IO [SourceMark]
sourceBufferGetSourceMarksAtLine buffer line category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_get_source_marks_at_line #}
    buffer
    (fromIntegral line)
    categoryPtr
  >>= readGSList
  >>= mapM (\markPtr -> makeNewGObject mkSourceMark (return markPtr))

-- | Returns the list of marks of the given category at iter. If category is empty it returns all marks at
-- iter.
sourceBufferGetSourceMarksAtIter :: SourceBuffer -- ^ @buffer@   a 'SourceBuffer'.
                                 -> TextIter -- ^ @iter@     an iterator.
                                 -> String -- ^ @category@ category to search for or empty
                                 -> IO [SourceMark]
sourceBufferGetSourceMarksAtIter buffer iter category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_get_source_marks_at_iter #}
    buffer
    iter
    categoryPtr
  >>= readGSList
  >>= mapM (\markPtr -> makeNewGObject mkSourceMark (return markPtr))

-- | Remove all marks of category between start and end from the buffer. If category is empty, all marks
-- in the range will be removed.
sourceBufferRemoveSourceMarks :: SourceBuffer -- ^ @buffer@   a 'SourceBuffer'.
                              -> TextIter -- ^ @start@    a 'TextIter'
                              -> TextIter -- ^ @end@      a 'TextIter'
                              -> String -- ^ @category@ category to search for or empty
                              -> IO ()
sourceBufferRemoveSourceMarks buffer start end category =
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_remove_source_marks #}
     buffer
     start
     end
     categoryPtr

-- | Moves iter to the position of the next 'SourceMark' of the given category. Returns 'True' if iter was
-- moved. If category is empty, the next source mark can be of any category.
sourceBufferForwardIterToSourceMark :: SourceBuffer -- ^ @buffer@   a 'SourceBuffer'.
                                    -> TextIter -- ^ @iter@     an iterator.
                                    -> String -- ^ @category@ category to search for or emtpy
                                    -> IO Bool -- ^ returns  whether iter moved.
sourceBufferForwardIterToSourceMark buffer iter category =
  liftM toBool $
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_forward_iter_to_source_mark #}
    buffer
    iter
    categoryPtr

-- | Moves iter to the position of the previous 'SourceMark' of the given category. Returns 'True' if iter
-- was moved. If category is empty, the previous source mark can be of any category.
sourceBufferBackwardIterToSourceMark :: SourceBuffer  -- ^ @buffer@   a 'SourceBuffer'.
                                     -> TextIter -- ^ @iter@     an iterator.
                                     -> String -- ^ @category@ category to search for or emtpy
                                     -> IO Bool -- ^ returns  whether iter moved.
sourceBufferBackwardIterToSourceMark buffer iter category =
  liftM toBool $
  withCString category $ \categoryPtr ->
  {#call gtk_source_buffer_backward_iter_to_source_mark #}
    buffer
    iter
    categoryPtr

-- | Forces buffer to analyze and highlight the given area synchronously.
--
-- Note
--
-- This is a potentially slow operation and should be used only when you need to make sure that some
-- text not currently visible is highlighted, for instance before printing.
sourceBufferEnsureHighlight :: SourceBuffer
                            -> TextIter  -- ^ @start@  start of the area to highlight.
                            -> TextIter  -- ^ @end@    end of the area to highlight.
                            -> IO ()
sourceBufferEnsureHighlight sb start end =
    {#call source_buffer_ensure_highlight#} sb start end

-- | Whether Redo operation is possible.
--
-- Default value: 'False'
--
sourceBufferCanRedo :: ReadAttr SourceBuffer Bool
sourceBufferCanRedo = readAttrFromBoolProperty "can-redo"

-- | Whether Undo operation is possible.
--
-- Default value: 'False'
sourceBufferCanUndo :: ReadAttr SourceBuffer Bool
sourceBufferCanUndo = readAttrFromBoolProperty "can-undo"

-- | Whether to highlight matching brackets in the buffer.
--
-- Default value: 'True'
--
sourceBufferHighlightMatchingBrackets :: Attr SourceBuffer Bool
sourceBufferHighlightMatchingBrackets = newAttrFromBoolProperty "highlight-matching-brackets"

-- | Whether to highlight syntax in the buffer.
--
-- Default value: 'True'
--
sourceBufferHighlightSyntax :: Attr SourceBuffer Bool
sourceBufferHighlightSyntax = newAttrFromBoolProperty "highlight-matching-brackets"

-- | Language object to get highlighting patterns from.
--
sourceBufferLanguage :: Attr SourceBuffer (Maybe SourceLanguage)
sourceBufferLanguage = newAttrFromMaybeObjectProperty "language" gTypeSourceLanguage

-- | Number of undo levels for the buffer. -1 means no limit. This property will only affect the default
-- undo manager.
--
-- Allowed values: >= GMaxulong
--
-- Default value: 1000
--
sourceBufferMaxUndoLevels :: Attr SourceBuffer Int
sourceBufferMaxUndoLevels = newAttrFromIntProperty "max-undo-levels"

-- | Style scheme. It contains styles for syntax highlighting, optionally foreground, background, cursor
-- color, current line color, and matching brackets style.
--
sourceBufferSourceStyleScheme :: Attr SourceBuffer (Maybe SourceStyleScheme)
sourceBufferSourceStyleScheme = newAttrFromMaybeObjectProperty "style-scheme" gTypeSourceStyleScheme

-- |
--
sourceBufferHighlightUpdated :: Signal SourceBuffer (TextIter -> TextIter -> IO ())
sourceBufferHighlightUpdated = Signal $ connect_BOXED_BOXED__NONE "highlight-updated" mkTextIterCopy mkTextIterCopy

-- |
--
sourceBufferRedoSignal :: Signal SourceBuffer (IO ())
sourceBufferRedoSignal = Signal $ connect_NONE__NONE "redo"

-- |
--
sourceBufferUndoSignal :: Signal SourceBuffer (IO ())
sourceBufferUndoSignal = Signal $ connect_NONE__NONE "undo"

-- | The 'sourceBufferMarkUpdated' signal is emitted each time a mark is added to, moved or removed from the
-- buffer.
--
sourceBufferSourceMarkUpdated :: Signal SourceBuffer (TextMark -> IO ())
sourceBufferSourceMarkUpdated = Signal $ connect_OBJECT__NONE "source-mark-updated"


Fix bugs in contour commit (eb5091)

Fix bugs in contour commit (eb5091)

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
-- | This module contains functions for extracting features from connected components
--   of black and white images as well as extracting other shape related features.
module CV.ConnectedComponents
       (
       -- * Working with connected components
        fillConnectedComponents
       ,maskConnectedComponent
       ,selectSizedComponents
       ,ContourMode(..)
       ,countBlobs
       -- * Working with Image moments
       -- |Note that these functions should probably go to a different module, since
       --  they deal with entire moments of entire images.
       ,spatialMoments
       ,centralMoments
       ,normalizedCentralMoments
       ,huMoments
       -- * Working with component contours aka. object boundaries.
       -- |This part is really old code and probably could be improved a lot.
       ,Contours
       ,ContourFunctionUS
       ,getContours
       ,contourArea
       ,contourPerimeter
       ,contourPoints
       ,mapContours
       ,contourHuMoments)
where
#include "cvWrapLEO.h"

import CV.Bindings.ImgProc
import CV.Bindings.Types
import Control.Monad ((>=>))
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
{#import CV.Image#}

import CV.ImageOp

fillConnectedComponents :: Image GrayScale D8 -> (Image GrayScale D8, Int)
fillConnectedComponents image = unsafePerformIO $ do
  let
    count :: CInt
    count = 0
  withCloneValue image $ \clone ->
    withImage clone $ \pclone ->
      with count $ \pcount -> do
        c'fillConnectedComponents (castPtr pclone) pcount
        c <- peek pcount
        return (clone, fromIntegral c)

maskConnectedComponent :: Image GrayScale D8 -> Int -> Image GrayScale D8
maskConnectedComponent image index = unsafePerformIO $
  withCloneValue image $ \clone ->
    withImage image $ \pimage ->
      withImage clone $ \pclone -> do
        c'maskConnectedComponent (castPtr pimage) (castPtr pclone) (fromIntegral index)
        return clone

-- |Count the number of connected components in the image
countBlobs :: Image GrayScale D8 -> Int
countBlobs image = fromIntegral $ unsafePerformIO $ do
    withGenImage image $ \i ->
     {#call blobCount#} i

-- |Remove all connected components that fall outside of given size range from the image.
selectSizedComponents :: Double -> Double -> ContourMode -> Image GrayScale D8 -> Image GrayScale D8
selectSizedComponents minSize maxSize mode image = unsafePerformIO $ do
    withGenImage image $ \i ->
     creatingImage ({#call sizeFilter#} i (realToFrac minSize) (realToFrac maxSize) (fromIntegral $ fromEnum mode))

#c
enum ContourMode {
    ContourExternal = CV_RETR_EXTERNAL
    , ContourAll    = CV_RETR_LIST
    , ContourBasicHeirarchy = CV_RETR_CCOMP
    , ContourFullHeirarchy  = CV_RETR_TREE
    };
#endc

{#enum ContourMode {} #}

-- * Working with Image moments.

-- Utility function for getting the moments
getMoments :: (Ptr C'CvMoments -> CInt -> CInt -> IO (CDouble)) -> Image GrayScale D32 -> Bool -> [Double]
getMoments f image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments :: C'CvMoments
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
      ms <- sequence [ f pmoments i j
                       | i <- [0..3], j <- [0..3], i+j <= 3 ]
      return (map realToFrac ms)

-- | Extract raw spatial moments of the image.
spatialMoments = getMoments c'cvGetSpatialMoment

-- | Extract central moments of the image. These are useful for describing the
--   object shape for a classifier system.
centralMoments = getMoments c'cvGetCentralMoment

-- | Extract normalized central moments of the image.
normalizedCentralMoments = getMoments c'cvGetNormalizedCentralMoment

{-
centralMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   ms <- sequence [{#call cvGetCentralMoment#} moments i j
                  | i <- [0..3], j<-[0..3], i+j <= 3]
   {#call freeCvMoments#} moments
   return (map realToFrac ms)
-}

-- |Extract Hu-moments of the image. These features are rotation invariant.
huMoments :: Image GrayScale D32 -> Bool -> [Double]
huMoments image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      hu = C'CvHuMoments 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      with hu $ \phu -> do
        c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
        c'cvGetHuMoments pmoments phu
        (C'CvHuMoments hu1 hu2 hu3 hu4 hu5 hu6 hu7) <- peek phu
        return (map realToFrac [hu1,hu2,hu3,hu4,hu5,hu6,hu7])

{-
huMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   hu <- readHu moments
   {#call freeCvMoments#} moments
   return (map realToFrac hu)
-}

-- read stuff out of hu-moments structure.. This could be done way better.
readHu m = do
   hu <- mallocArray 7
   {#call getHuMoments#} m hu
   hu' <- peekArray 7 hu
   free hu
   return hu'

-- |Structure that contains the opencv sequence holding the contour data.
{#pointer *FoundContours as Contours foreign newtype#}
foreign import ccall "& free_found_contours" releaseContours
    :: FinalizerPtr Contours

-- | This function maps an opencv contour calculation over all
--   contours of the image.
mapContours :: ContourFunctionUS a -> Contours -> [a]
mapContours (CFUS op) contours = unsafePerformIO $ do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

-- |Extract contours of connected components of the image.
getContours :: Image GrayScale D8 -> Contours
getContours img = unsafePerformIO $ do
        withImage img $ \i -> do
          ptr <- {#call get_contours#} i
          fptr <- newForeignPtr releaseContours ptr
          return $ Contours fptr

newtype ContourFunctionUS a = CFUS (Contours -> IO a)
newtype ContourFunctionIO a = CFIO (Contours -> IO a)

rawContourOpUS op = CFUS $ \c -> withContours c op
rawContourOp op = CFIO $ \c -> withContours c op

printContour = rawContourOp {#call print_contour#}

contourArea :: ContourFunctionUS Double
contourArea = rawContourOpUS ({#call contour_area#} >=> return.realToFrac)
-- ^The area of a contour.

contourPerimeter :: ContourFunctionUS Double
contourPerimeter = rawContourOpUS $ {#call contour_perimeter#} >=> return.realToFrac
-- ^Get the perimeter of a contour.

-- |Get a list of the points in the contour.
contourPoints :: ContourFunctionUS [(Double,Double)]
contourPoints = rawContourOpUS getContourPoints'
getContourPoints' f = do
     count <- {#call cur_contour_size#} f
     let count' = fromIntegral count
     ----print count
     xs <- mallocArray count'
     ys <- mallocArray count'
     {#call contour_points#} f xs ys
     xs' <- peekArray count' xs
     ys' <- peekArray count' ys
     free xs
     free ys
     return $ zip (map fromIntegral xs') (map fromIntegral ys')

-- | Operation for extracting Hu-moments from a contour
contourHuMoments :: ContourFunctionUS [Double]
contourHuMoments = rawContourOpUS $ getContourHuMoments' >=> return.map realToFrac
getContourHuMoments' f = do
   m <- {#call contour_moments#} f
   hu <- readHu m
   {#call freeCvMoments#} m
   return hu

mapContoursIO :: ContourFunctionIO a -> Contours -> IO [a]
mapContoursIO (CFIO op) contours = do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

{#pointer *CvMoments as Moments foreign newtype#}

{-#LANGUAGE ForeignFunctionInterface, ScopedTypeVariables#-}
-- | This module contains functions for extracting features from connected components
--   of black and white images as well as extracting other shape related features.
module CV.ConnectedComponents
       (
       -- * Working with connected components
        fillConnectedComponents
       ,maskConnectedComponent
       ,selectSizedComponents
       ,contourMode
       ,countBlobs
       -- * Working with Image moments
       -- |Note that these functions should probably go to a different module, since
       --  they deal with entire moments of entire images.
       ,spatialMoments
       ,centralMoments
       ,normalizedCentralMoments
       ,huMoments
       -- * Working with component contours aka. object boundaries.
       -- |This part is really old code and probably could be improved a lot.
       ,Contours
       ,ContourFunctionUS
       ,getContours
       ,contourArea
       ,contourPerimeter
       ,contourPoints
       ,mapContours
       ,contourHuMoments)
where
#include "cvWrapLEO.h"

import CV.Bindings.ImgProc
import CV.Bindings.Types
import Control.Monad ((>=>))
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe
{#import CV.Image#}

import CV.ImageOp

fillConnectedComponents :: Image GrayScale D8 -> (Image GrayScale D8, Int)
fillConnectedComponents image = unsafePerformIO $ do
  let
    count :: CInt
    count = 0
  withCloneValue image $ \clone ->
    withImage clone $ \pclone ->
      with count $ \pcount -> do
        c'fillConnectedComponents (castPtr pclone) pcount
        c <- peek pcount
        return (clone, fromIntegral c)

maskConnectedComponent :: Image GrayScale D8 -> Int -> Image GrayScale D8
maskConnectedComponent image index = unsafePerformIO $
  withCloneValue image $ \clone ->
    withImage image $ \pimage ->
      withImage clone $ \pclone -> do
        c'maskConnectedComponent (castPtr pimage) (castPtr pclone) (fromIntegral index)
        return clone

-- |Count the number of connected components in the image
countBlobs :: Image GrayScale D8 -> Int
countBlobs image = fromIntegral $ unsafePerformIO $ do
    withGenImage image $ \i ->
     {#call blobCount#} i

-- |Remove all connected components that fall outside of given size range from the image.
selectSizedComponents :: Double -> Double -> ContourMode -> Image GrayScale D8 -> Image GrayScale D8
selectSizedComponents minSize maxSize mode image = unsafePerformIO $ do
    withGenImage image $ \i ->
     creatingImage ({#call sizeFilter#} i (realToFrac minSize) (realToFrac maxSize) (fromIntegral $ fromEnum mode))

#c
enum ContourMode {
    ContourExternal = CV_RETR_EXTERNAL
    , ContourAll    = CV_RETR_LIST
    , ContourBasicHeirarchy = CV_RETR_CCOMP
    , ContourFullHeirarchy  = CV_RETR_TREE
    };
#endc

{#enum ContourMode {} #}

-- * Working with Image moments.

-- Utility function for getting the moments
getMoments :: (Ptr C'CvMoments -> CInt -> CInt -> IO (CDouble)) -> Image GrayScale D32 -> Bool -> [Double]
getMoments f image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments :: C'CvMoments
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
      ms <- sequence [ f pmoments i j
                       | i <- [0..3], j <- [0..3], i+j <= 3 ]
      return (map realToFrac ms)

-- | Extract raw spatial moments of the image.
spatialMoments = getMoments c'cvGetSpatialMoment

-- | Extract central moments of the image. These are useful for describing the
--   object shape for a classifier system.
centralMoments = getMoments c'cvGetCentralMoment

-- | Extract normalized central moments of the image.
normalizedCentralMoments = getMoments c'cvGetNormalizedCentralMoment

{-
centralMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   ms <- sequence [{#call cvGetCentralMoment#} moments i j
                  | i <- [0..3], j<-[0..3], i+j <= 3]
   {#call freeCvMoments#} moments
   return (map realToFrac ms)
-}

-- |Extract Hu-moments of the image. These features are rotation invariant.
huMoments :: Image GrayScale D32 -> Bool -> [Double]
huMoments image binary = unsafePerformIO $ do
  withImage image $ \pimage -> do
    let
      moments = C'CvMoments 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
      hu = C'CvHuMoments 0 0 0 0 0 0 0
    with moments $ \pmoments -> do
      with hu $ \phu -> do
        c'cvMoments (castPtr pimage) pmoments (if binary then 1 else 0)
        c'cvGetHuMoments pmoments phu
        (C'CvHuMoments hu1 hu2 hu3 hu4 hu5 hu6 hu7) <- peek phu
        return (map realToFrac [hu1,hu2,hu3,hu4,hu5,hu6,hu7])

{-
huMoments image binary = unsafePerformIO $ do
   moments <- withImage image $ \i -> {#call getMoments#} i (if binary then 1 else 0)
   hu <- readHu moments
   {#call freeCvMoments#} moments
   return (map realToFrac hu)
-}

-- read stuff out of hu-moments structure.. This could be done way better.
readHu m = do
   hu <- mallocArray 7
   {#call getHuMoments#} m hu
   hu' <- peekArray 7 hu
   free hu
   return hu'

-- |Structure that contains the opencv sequence holding the contour data.
{#pointer *FoundContours as Contours foreign newtype#}
foreign import ccall "& free_found_contours" releaseContours
    :: FinalizerPtr Contours

-- | This function maps an opencv contour calculation over all
--   contours of the image.
mapContours :: ContourFunctionUS a -> Contours -> [a]
mapContours (CFUS op) contours = unsafePerformIO $ do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

-- |Extract contours of connected components of the image.
getContours :: Image GrayScale D8 -> Contours
getContours img = unsafePerformIO $ do
        withImage img $ \i -> do
          ptr <- {#call get_contours#} i
          fptr <- newForeignPtr releaseContours ptr
          return $ Contours fptr

newtype ContourFunctionUS a = CFUS (Contours -> IO a)
newtype ContourFunctionIO a = CFIO (Contours -> IO a)

rawContourOpUS op = CFUS $ \c -> withContours c op
rawContourOp op = CFIO $ \c -> withContours c op

printContour = rawContourOp {#call print_contour#}

contourArea :: ContourFunctionUS Double
contourArea = rawContourOpUS ({#call contour_area#} >=> return.realToFrac)
-- ^The area of a contour.

contourPerimeter :: ContourFunctionUS Double
contourPerimeter = rawContourOpUS $ {#call contour_perimeter#} >=> return.realToFrac
-- ^Get the perimeter of a contour.

-- |Get a list of the points in the contour.
contourPoints :: ContourFunctionUS [(Double,Double)]
contourPoints = rawContourOpUS getContourPoints'
getContourPoints' f = do
     count <- {#call cur_contour_size#} f
     let count' = fromIntegral count
     ----print count
     xs <- mallocArray count'
     ys <- mallocArray count'
     {#call contour_points#} f xs ys
     xs' <- peekArray count' xs
     ys' <- peekArray count' ys
     free xs
     free ys
     return $ zip (map fromIntegral xs') (map fromIntegral ys')

-- | Operation for extracting Hu-moments from a contour
contourHuMoments :: ContourFunctionUS [Double]
contourHuMoments = rawContourOpUS $ getContourHuMoments' >=> return.map realToFrac
getContourHuMoments' f = do
   m <- {#call contour_moments#} f
   hu <- readHu m
   {#call freeCvMoments#} m
   return hu

mapContoursIO :: ContourFunctionIO a -> Contours -> IO [a]
mapContoursIO (CFIO op) contours = do
    let loop acc cp = do
        more <- withContours cp {#call more_contours#}
        if more < 1
            then return acc
            else do
                x <- op cp
                (i::CInt) <- withContours cp {#call next_contour#}
                loop (x:acc) cp

    acc <- loop [] contours
    withContours contours ({#call reset_contour#})
    return acc

{#pointer *CvMoments as Moments foreign newtype#}