fix build failure on haddock-2.10.0

fix build failure on haddock-2.10.0

Checking module Graphics.UI.Gtk.WebKit.WebFrame...
Creating interface...
haddock: internal error: lexical error
/usr/bin/haddock returned ExitFailure 1

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
-----------------------------------------------------------------------------
--  Module      :  Graphics.UI.Gtk.WebKit.WebFrame
--  Author      :  Cjacker Huang
--  Copyright   :  (c) 2009 Cjacker Huang <jzhuang@redflag-linux.com>
--  Copyright   :  (c) 2010 Andy Stewart <lazycat.manatee@gmail.com>
--
--  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)
--
-- The content of a 'WebView'
--
-- Note:
-- Functon `webkit_web_frame_get_global_context` can't binding now,
-- Because it need `JSGlobalContextRef` exist in JavaScriptCore.
--
-- Function `webkit_web_frame_print_full` can't binding now,
-- Because library `GtkPrintOperation` haven't binding.
--
-----------------------------------------------------------------------------

module Graphics.UI.Gtk.WebKit.WebFrame (
-- * Description
-- | A WebKitWebView contains a main WebKitWebFrame. A WebKitWebFrame contains the content of one
-- URI. The URI and name of the frame can be retrieved, the load status and progress can be observed
-- using the signals and can be controlled using the methods of the WebKitWebFrame. A WebKitWebFrame
-- can have any number of children and one child can be found by using 'webFrameFindFrame'.

-- * Types
  WebFrame,
  WebFrameClass,
  LoadStatus,

-- * Constructors
  webFrameNew,

-- * Methods
  webFrameGetWebView,
  webFrameGetName,
#if WEBKIT_CHECK_VERSION (1,1,18)
  webFrameGetNetworkResponse,
#endif
  webFrameGetTitle,
  webFrameGetUri,
  webFrameGetParent,
  webFrameGetLoadStatus,
  webFrameLoadUri,
  webFrameLoadString,
  webFrameLoadAlternateString,
  webFrameLoadRequest,
  webFrameStopLoading,
  webFrameReload,
  webFrameFindFrame,
  webFrameGetDataSource,
  webFrameGetHorizontalScrollbarPolicy,
  webFrameGetVerticalScrollbarPolicy,
  webFrameGetProvisionalDataSource,
  webFrameGetSecurityOrigin,
  webFramePrint,
) where

import Control.Monad		(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList
import System.Glib.GError
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk.General.Enums

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

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

-- * Enums

{#enum LoadStatus {underscoreToCase}#}

------------------
-- Constructors

-- | Create a new 'WebFrame' instance with the given @webview@.
--
-- A 'WebFrame' contains the content of one URI.
webFrameNew ::
    WebViewClass webview => webview  -- ^ @webview@ - the given webview
 -> IO WebFrame
webFrameNew webview =
    wrapNewGObject mkWebFrame $ {#call web_frame_new#} (toWebView webview)

-- | Return the 'WebView' that manages the given 'WebFrame'.
webFrameGetWebView ::
    WebFrameClass self => self
 -> IO WebView
webFrameGetWebView webframe =
    makeNewObject mkWebView $ liftM castPtr $ {#call web_frame_get_web_view#} (toWebFrame webframe)

-- | Return the name of the given 'WebFrame'.
webFrameGetName ::
    WebFrameClass self => self
 -> IO (Maybe String) -- ^ the name string or @Nothing@ in case failed.
webFrameGetName webframe =
    {#call web_frame_get_name#} (toWebFrame webframe) >>= maybePeek peekCString

#if WEBKIT_CHECK_VERSION (1,1,18)
-- | Returns a WebKitNetworkResponse object representing the response that was given to the request for
-- the given frame, or 'Nothing' if the frame was not created by a load.
--
-- * Since 1.1.18
webFrameGetNetworkResponse :: WebFrameClass self => self -> IO (Maybe NetworkResponse)
webFrameGetNetworkResponse frame =
    maybeNull (makeNewGObject mkNetworkResponse) $
   {#call webkit_web_frame_get_network_response#} (toWebFrame frame)
#endif

-- | Return the title of the given 'WebFrame'.
webFrameGetTitle ::
    WebFrameClass self => self
 -> IO (Maybe String) -- ^ the title string or @Nothing@ in case failed.
webFrameGetTitle webframe =
    {#call web_frame_get_title#} (toWebFrame webframe) >>= maybePeek peekCString

-- | Return the URI of the given 'WebFrame'.
webFrameGetUri ::
    WebFrameClass self => self
 -> IO (Maybe String) -- ^ the URI string or @Nothing@ in case failed.
webFrameGetUri webframe =
    {#call web_frame_get_uri#} (toWebFrame webframe) >>= maybePeek peekCString

-- | Return the 'WebFrame''s parent frame if it has one,
-- Otherwise return Nothing.
webFrameGetParent ::
    WebFrameClass self => self
 -> IO (Maybe WebFrame) -- ^ a 'WebFrame' or @Nothing@ in case failed.
webFrameGetParent webframe =
    maybeNull (makeNewGObject mkWebFrame) $ {#call web_frame_get_parent#} (toWebFrame webframe)

-- | Determines the current status of the load.
--
-- frame :   a WebKitWebView
--
-- * Since 1.1.7
webFrameGetLoadStatus ::
    WebFrameClass self => self
 -> IO LoadStatus
webFrameGetLoadStatus ls =
    liftM (toEnum . fromIntegral) $ {#call web_frame_get_load_status#} (toWebFrame ls)

-- | Request loading of the specified URI string.
webFrameLoadUri ::
    WebFrameClass self => self
 -> String -- ^ @uri@ - an URI string.
 -> IO ()
webFrameLoadUri webframe uri =
    withCString uri $ \uriPtr -> {#call web_frame_load_uri#}
    (toWebFrame webframe)
    uriPtr

-- | Requests loading of the given @content@
-- with the specified @mime_type@, @encoding@ and @base_uri@.
--
-- If @mime_type@ is @Nothing@, \"text/html\" is assumed.
--
-- If @encoding@ is @Nothing@, \"UTF-8\" is assumed.
webFrameLoadString ::
    WebFrameClass self => self
 -> String -- ^ @content@ - the content string to be loaded.
 -> (Maybe String) -- ^ @mime_type@ - the MIME type or @Nothing@.
 -> (Maybe String) -- ^ @encoding@ - the encoding or @Nothing@.
 -> String -- ^ @base_uri@ - the base URI for relative locations.
 -> IO()
webFrameLoadString webframe content mimetype encoding baseuri =
    withCString content  $ \contentPtr ->
    maybeWith withCString mimetype $ \mimetypePtr ->
    maybeWith withCString encoding $ \encodingPtr ->
    withCString baseuri  $ \baseuriPtr ->
        {#call web_frame_load_string#}
          (toWebFrame webframe)
          contentPtr
          mimetypePtr
          encodingPtr
          baseuriPtr

-- |Request loading of an alternate content for a URL that is unreachable.
--
-- Using this method will preserve the back-forward list.
-- The URI passed in @base_uri@ has to be an absolute URI.
webFrameLoadAlternateString ::
    WebFrameClass self => self
 -> String  -- ^ @content@ - the alternate content to display
            -- as the main page of the frame
 -> String  -- ^ @base_uri@ - the base URI for relative locations.
 -> String  -- ^ @unreachable_url@ - the URL for the alternate page content.
 -> IO()
webFrameLoadAlternateString webframe content baseurl unreachableurl =
    withCString content  $ \contentPtr ->
    withCString baseurl  $ \baseurlPtr ->
    withCString unreachableurl  $ \unreachableurlPtr ->
        {#call web_frame_load_alternate_string#}
          (toWebFrame webframe)
          contentPtr
          baseurlPtr
          unreachableurlPtr

-- | Connects to a given URI by initiating an asynchronous client request.
--
-- Creates a provisional data source that will transition to a committed data source once any data has been received.
-- Use 'webFrameStopLoading' to stop the load.
-- This function is typically invoked on the main frame.
webFrameLoadRequest ::
   (WebFrameClass self, NetworkRequestClass requ) => self -> requ
 -> IO ()
webFrameLoadRequest webframe request =
  {#call web_frame_load_request#} (toWebFrame webframe) (toNetworkRequest request)

-- | Stops and pending loads on the given data source and those of its children.
webFrameStopLoading ::
    WebFrameClass self => self
 -> IO()
webFrameStopLoading webframe =
    {#call web_frame_stop_loading#} (toWebFrame webframe)

-- |Reloads the initial request.
webFrameReload ::
    WebFrameClass self => self
 -> IO()
webFrameReload webframe =
    {#call web_frame_reload#} (toWebFrame webframe)

-- |Return the 'WebFrame' associated with the given name
-- or @Nothing@ in case none if found
--
-- For pre-defined names, return the given webframe if name is
webFrameFindFrame::
    WebFrameClass self => self
 -> String  -- ^ @name@ - the name of the frame to be found.
 -> IO (Maybe WebFrame)
webFrameFindFrame webframe name =
    withCString name $ \namePtr ->
	maybeNull (makeNewGObject mkWebFrame) $
          {#call web_frame_find_frame#} (toWebFrame webframe) namePtr

-- | Returns the committed data source.
webFrameGetDataSource ::
   WebFrameClass self => self
 -> IO WebDataSource
webFrameGetDataSource webframe =
  makeNewGObject mkWebDataSource $ {#call web_frame_get_data_source#} (toWebFrame webframe)

-- | Return the policy of horizontal scrollbar.
webFrameGetHorizontalScrollbarPolicy ::
   WebFrameClass self => self
 -> IO PolicyType
webFrameGetHorizontalScrollbarPolicy webframe =
    liftM (toEnum.fromIntegral) $
    {#call web_frame_get_horizontal_scrollbar_policy#} (toWebFrame webframe)

-- | Return the policy of vertical scrollbar.
webFrameGetVerticalScrollbarPolicy ::
   WebFrameClass self => self
 -> IO PolicyType
webFrameGetVerticalScrollbarPolicy webframe =
    liftM (toEnum.fromIntegral) $
    {#call web_frame_get_vertical_scrollbar_policy#} (toWebFrame webframe)

-- | You use the 'webFrameLoadRequest' method to initiate a request that creates a provisional data source.
-- The provisional data source will transition to a committed data source once any data has been received.
-- Use 'webFrameGetDataSource' to get the committed data source.
webFrameGetProvisionalDataSource ::
   WebFrameClass self => self
 -> IO WebDataSource
webFrameGetProvisionalDataSource webframe =
  makeNewGObject mkWebDataSource $ {#call web_frame_get_provisional_data_source#} (toWebFrame webframe)

-- | Returns the frame's security origin.
webFrameGetSecurityOrigin ::
   WebFrameClass self => self
 -> IO SecurityOrigin
webFrameGetSecurityOrigin webframe =
  makeNewGObject mkSecurityOrigin $ {#call web_frame_get_security_origin#} (toWebFrame webframe)

-- |Prints the given 'WebFrame'.
--
-- by presenting a print dialog to the user.
webFramePrint::
    WebFrameClass self => self
 -> IO()
webFramePrint webframe =
  {#call web_frame_print#} (toWebFrame webframe)


Some additional color handling.

Some additional color handling.

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns#-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

{#pointer *IplImage as Image foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr Image

instance NFData Image where
    rnf a@(Image fptr) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return.Image $ fptr

unImage (Image fptr) = fptr
composeMultichannelImage :: Maybe Image -> Maybe Image -> Maybe Image -> Maybe Image -> Image
composeMultichannelImage c1 c2 c3 c4 = unsafePerformIO $ do
        res <- createImage32F (size) 4 -- TODO: Check channel count
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return $ Just bw
loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return $ Just bw

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.
convertToGrayScale img = unsafePerformIO $ creatingImage $ do
    res <- {#call wrapCreateImage32F#} w h 1
    withImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) cvRGBtoGRAY
    return res
 where
    (w,h) = getSize img

convertTo code channels img = unsafePerformIO $ creatingImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (w,h) = getSize img

createImage32F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage32F#} w h nChannels

createImage64F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage64F#} w h nChannels

createImage8U (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage8U#} w h nChannels

image32F size channels = unsafePerformIO $ createImage32F size channels
image8U size channels = unsafePerformIO $ createImage8U size channels

emptyCopy img = image32F (getSize img) 1

saveImage filename image = do
                           fpi <- imageTo8Bit image
                           withCString  filename $ \name  ->
                            withGenImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getSize image = unsafePerformIO $ withImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

getArea = uncurry (*).getSize

getRegion :: (Integral a) => (a, a) -> (a,a) -> Image -> Image
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = getRegion' (x,y) (w,h) image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (width,height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withImage image $ \i ->
                                 creatingImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
--blit image1 image2 (x,y) =
--                          withImage image1 $ \i1 ->
--                           withImage image2 $ \i2 ->
--                            ({#call plainBlit#} i1 i2 x y)
-- TODO: Remove the above
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0
subPixelBlit
  :: Image -> Image -> (CDouble, CDouble) -> IO ()

subPixelBlit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)
imageTo8Bit img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)
-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

getChannel no image = unsafePerformIO $ creatingImage $ do

    let (w,h) = getSize image
    setCOI no image
    cres <- {#call wrapCreateImage32F#} w h 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
setPixel :: (CInt,CInt) -> CDouble -> Image -> IO ()
setPixel (x,y) v image = withGenImage image $ \img ->
                          {#call wrapSet32F2D#} img y x v

getPixel :: (CInt,CInt) -> Image -> CDouble
getPixel (x,y) image = unsafePerformIO $ withGenImage image $ \img ->
                          {#call wrapGet32F2D#} img y x

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (Int,Int) -> Int -> [Image] -> Image
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- createImage32F (rw,rh) 1
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep) | y <- [0..v-1] , x <- [0..u-1] | i <- imgs ]
                    return r

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns#-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

{#pointer *IplImage as Image foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr Image

instance NFData Image where
    rnf a@(Image fptr) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return.Image $ fptr

unImage (Image fptr) = fptr
composeMultichannelImage :: Maybe Image -> Maybe Image -> Maybe Image -> Maybe Image -> Image
composeMultichannelImage c1 c2 c3 c4 = unsafePerformIO $ do
        res <- createImage32F (size) 4 -- TODO: Check channel count
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return $ Just bw
loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return $ Just bw

cvRGBtoGRAY = 7 -- NOTE: This will break.
convertToGrayScale img = unsafePerformIO $ creatingImage $ do
    res <- {#call wrapCreateImage32F#} w h 1
    withImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) cvRGBtoGRAY
    return res

 where
    (w,h) = getSize img

createImage32F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage32F#} w h nChannels

createImage64F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage64F#} w h nChannels

createImage8U (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage8U#} w h nChannels

image32F size channels = unsafePerformIO $ createImage32F size channels
image8U size channels = unsafePerformIO $ createImage8U size channels

emptyCopy img = image32F (getSize img) 1

saveImage filename image = do
                           fpi <- imageTo8Bit image
                           withCString  filename $ \name  ->
                            withGenImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getSize image = unsafePerformIO $ withImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

getArea = uncurry (*).getSize

getRegion :: (Integral a) => (a, a) -> (a,a) -> Image -> Image
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = getRegion' (x,y) (w,h) image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (width,height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withImage image $ \i ->
                                 creatingImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
--blit image1 image2 (x,y) =
--                          withImage image1 $ \i1 ->
--                           withImage image2 $ \i2 ->
--                            ({#call plainBlit#} i1 i2 x y)
-- TODO: Remove the above
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0
subPixelBlit
  :: Image -> Image -> (CDouble, CDouble) -> IO ()

subPixelBlit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)
imageTo8Bit img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)
-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
setPixel :: (CInt,CInt) -> CDouble -> Image -> IO ()
setPixel (x,y) v image = withGenImage image $ \img ->
                          {#call wrapSet32F2D#} img y x v

getPixel :: (CInt,CInt) -> Image -> CDouble
getPixel (x,y) image = unsafePerformIO $ withGenImage image $ \img ->
                          {#call wrapGet32F2D#} img y x

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (Int,Int) -> Int -> [Image] -> Image
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- createImage32F (rw,rh) 1
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep) | y <- [0..v-1] , x <- [0..u-1] | i <- imgs ]
                    return r


Only 8 more error messages before version 0.3 CV.Image!

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, TypeFamilies #-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

-- Colorspaces
data GrayScale
data RGB
data RGBA
data LAB

-- Bit Depths
data D8
data D32
data D64

newtype Image channels depth = S BareImage

unS (S i) = i -- Unsafe and ugly

withImage :: Image c d -> (Ptr BareImage ->IO a) -> IO a
withImage (S i) op = withBareImage i op
--withGenNewImage (S i) op = withGenImage i op

-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr BareImage

instance NFData (Image a b) where
    rnf a@(S (BareImage fptr)) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . S . BareImage $ fptr

creatingBareImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return . BareImage $ fptr

unImage (S (BareImage fptr)) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
lab = undefined :: Tag LAB

composeMultichannelImage :: (CreateImage (Image tp a)) => Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Maybe (Image GrayScale a) -> Tag tp -> Image tp a
composeMultichannelImage (c1)
                         (c2)
                         (c3)
                         (c4)
                         totag
    = unsafePerformIO $ do
        res <- create (size) -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

--loadImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name (0))
--                              bw <- imageTo32F i
--                              return $ Just bw

loadImage :: FilePath -> IO (Maybe (Image GrayScale Double))
loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return . Just . S $ bw

loadColorImage :: FilePath -> IO (Maybe (Image RGB Double))
loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingBareImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return . Just . S  $ bw

class Sized a where
    type SizeT a :: *
    getSize :: a -> SizeT a

instance Sized BareImage where
    type SizeT BareImage = (Int,Int)
   -- getSize :: (Integral a, Integral b) => Image c d -> (a,b)
    getSize image = unsafePerformIO $ withBareImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

instance Sized (Image c d) where
    type SizeT (Image c d) = (Int,Int)
    getSize = getSize . unS

--loadColorImage n = do
--              exists <- fileExist n
--              if not exists then return Nothing
--                            else do
--                              i <- withCString n $ \name ->
--                                     creatingImage ({#call cvLoadImage #} name 1)
--                              bw <- imageTo32F i
--                              return $ Just bw

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

rgbToLab :: Image RGB Double -> Image LAB Double
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: Image RGB Double -> Image GrayScale Double
rgbToGray = S . convertTo cvRGBtoGRAY 1 . unS

class GetPixel a where
    type P a :: *
    getPixel   :: (Integral i) => (i,i) -> a -> P a

instance GetPixel (Image GrayScale Double) where
    type P (Image GrayScale Double) = Double
    getPixel (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $
             withGenImage image $ \img -> {#call wrapGet32F2D#} img y x

instance  GetPixel (Image RGB Double) where
    type P (Image RGB Double) = (Double,Double,Double)
    getPixel (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

convertTo :: CInt -> CInt -> BareImage -> BareImage
convertTo code channels img = unsafePerformIO $ creatingBareImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withBareImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (fromIntegral -> w,fromIntegral -> h) = getSize img

class CreateImage a where
    create :: (Int,Int) -> IO a

instance CreateImage (Image GrayScale D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D32) where
    create (w,h) = creatingImage $ {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D64) where
    create (w,h) = creatingImage $ {#call wrapCreateImage64F#} (fromIntegral w) (fromIntegral h) 4

instance CreateImage (Image GrayScale D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 1
instance CreateImage (Image LAB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGB D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 3
instance CreateImage (Image RGBA D8) where
    create (w,h) = creatingImage $ {#call wrapCreateImage8U#} (fromIntegral w) (fromIntegral h) 4

emptyCopy img = create (getSize img)

saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit image
                           withCString  filename $ \name  ->
                            withGenImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

--getSize image = unsafePerformIO $ withImage image $ \i -> do
--                 w <- {#call getImageWidth#} i
--                 h <- {#call getImageHeight#} i
--                 return (fromIntegral w,fromIntegral h)

getArea = uncurry (*).getSize

getRegion :: (Integral a) => (a,a) -> (a,a) -> Image c d -> Image c d
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = S . getRegion' (x,y) (w,h) $ unS image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (width,height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withImage image $ \i ->
                                 creatingImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

blitM :: (Int,Int) -> [((Int,Int),Image c d)] -> Image c d
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- create (fromIntegral rw,fromIntegral rh)
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image c d -> Image c d -> (CDouble, CDouble) -> IO ()

subPixelBlit (unS -> image1) (unS -> image2) (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure32F #} image)

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI no image
    cres <- {#call wrapCreateImage32F#} w h 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
--setPixel :: (CInt,CInt) -> CDouble -> Image c d -> IO ()
--setPixel (x,y) v image = withGenImage image $ \img ->
--                          {#call wrapSet32F2D#} img y x v

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (Int,Int) -> Int -> [Image c d] -> Image c d
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- create (rw,rh) 1
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep) | y <- [0..v-1] , x <- [0..u-1] | i <- imgs ]
                    return r

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, TypeFamilies #-}
#include "cvWrapLeo.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

import Data.Maybe(catMaybes)
import Data.List(genericLength)
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import System.IO.Unsafe

data GrayScale
data RGB
data RGBA
data LAB

newtype NewImage channels depth = S Image

unS (S i ) = i -- Unsafe and ugly

withNewImage (S i) op = withImage i op >>= return . S
withGenNewImage (S i) op = withGenImage i op >>= return . S

{#pointer *IplImage as Image foreign newtype#}

foreign import ccall "& wrapReleaseImage" releaseImage :: FinalizerPtr Image

instance NFData Image where
    rnf a@(Image fptr) = (unsafeForeignPtrToPtr) fptr `seq` a `seq` ()-- This might also need peek?

creatingImage fun = do
              iptr <- fun
--              {#call incrImageC#} -- Uncomment this line to get statistics of number of images allocated by ghc
              fptr <- newForeignPtr releaseImage iptr
              return.Image $ fptr

unImage (Image fptr) = fptr

data Tag tp;
rgb = undefined :: Tag RGB
lab = undefined :: Tag LAB

composeMultichannelImageNew :: Maybe (NewImage GrayScale a) -> Maybe (NewImage GrayScale a) -> Maybe (NewImage GrayScale a) -> Maybe (NewImage GrayScale a) -> Tag tp -> NewImage tp a
composeMultichannelImageNew c1 c2 c3 c4 totag = S $ composeMultichannelImage (fmap unS c1) (fmap unS c2) (fmap unS c3) (fmap unS c4)

composeMultichannelImage :: Maybe Image -> Maybe Image -> Maybe Image -> Maybe Image -> Image
composeMultichannelImage c1 c2 c3 c4 = unsafePerformIO $ do
        res <- createImage32F (size) 4 -- TODO: Check channel count -- This is NOT correct
        withMaybe c1 $ \cc1 ->
         withMaybe c2 $ \cc2 ->
          withMaybe c3 $ \cc3 ->
           withMaybe c4 $ \cc4 ->
            withGenImage res $ \cres -> {#call cvMerge#} cc1 cc2 cc3 cc4 cres
        return res
    where
        withMaybe (Just i) op = withGenImage i op
        withMaybe (Nothing) op = op nullPtr
        size = getSize . head . catMaybes $ [c1,c2,c3,c4]

-- Load Image as grayscale image.

loadImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return $ Just bw

loadImageNew :: FilePath -> IO (Maybe (NewImage GrayScale Double))
loadImageNew n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name (0))
                              bw <- imageTo32F i
                              return . Just . S $ bw

loadColorImageNew :: FilePath -> IO (Maybe (NewImage RGB Double))
loadColorImageNew n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return . Just . S  $ bw

getSizeNew :: (Integral a, Integral b) => NewImage c d -> (a,b)
getSizeNew image = unsafePerformIO $ withImage (unS image) $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

loadColorImage n = do
              exists <- fileExist n
              if not exists then return Nothing
                            else do
                              i <- withCString n $ \name ->
                                     creatingImage ({#call cvLoadImage #} name 1)
                              bw <- imageTo32F i
                              return $ Just bw

cvRGBtoGRAY = 7 :: CInt-- NOTE: This will break.
cvRGBtoLAB = 45 :: CInt-- NOTE: This will break.

convertToGrayScale img = unsafePerformIO $ creatingImage $ do
    res <- {#call wrapCreateImage32F#} w h 1
    withImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) cvRGBtoGRAY
    return res
 where
    (w,h) = getSize img

rgbToLab :: NewImage RGB Double -> NewImage LAB Double
rgbToLab = S . convertTo cvRGBtoLAB 3 . unS

rgbToGray :: NewImage RGB Double -> NewImage GrayScale Double
rgbToGray = S . convertToGrayScale . unS

getRegionNew :: (Integral a) => (a,a) -> (a,a) -> NewImage c d -> NewImage c d
getRegionNew a b
    = S . getRegion a b . unS

class GetPixel a where
    type P a :: *
    getPixelNew   :: (Integral i) => (i,i) -> a -> P a

instance GetPixel (NewImage GrayScale Double) where
    type P (NewImage GrayScale Double) = Double
    getPixelNew (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $ withGenImage (unS image) $ \img ->
                              {#call wrapGet32F2D#} img y x

instance  GetPixel (NewImage RGB Double) where
    type P (NewImage RGB Double) = (Double,Double,Double)
    getPixelNew (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage (unS image) $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

convertTo code channels img = unsafePerformIO $ creatingImage $ do
    res <- {#call wrapCreateImage32F#} w h channels
    withImage img $ \cimg ->
        {#call cvCvtColor#} (castPtr cimg) (castPtr res) code
    return res
 where
    (w,h) = getSize img

createImage32F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage32F#} w h nChannels

createImage64F (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage64F#} w h nChannels

createImage8U (w,h) nChannels = do
    creatingImage $ {#call wrapCreateImage8U#} w h nChannels

image32F size channels = unsafePerformIO $ createImage32F size channels
image8U size channels = unsafePerformIO $ createImage8U size channels

emptyCopy img = image32F (getSize img) 1

saveImage filename image = do
                           fpi <- imageTo8Bit image
                           withCString  filename $ \name  ->
                            withGenImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getSize image = unsafePerformIO $ withImage image $ \i -> do
                 w <- {#call getImageWidth#} i
                 h <- {#call getImageHeight#} i
                 return (fromIntegral w,fromIntegral h)

getArea = uncurry (*).getSize

getRegion :: (Integral a) => (a, a) -> (a,a) -> Image -> Image
getRegion (fromIntegral -> x,fromIntegral -> y) (fromIntegral -> w,fromIntegral -> h) image
    | x+w <= width && y+h <= height = getRegion' (x,y) (w,h) image
    | otherwise                   = error $ "Region outside image:"
                                            ++ show (getSize image) ++
                                            "/"++show (x+w,y+h)
 where
  (width,height) = getSize image

getRegion' (x,y) (w,h) image = unsafePerformIO $
                               withImage image $ \i ->
                                 creatingImage ({#call getSubImage#}
                                                i x y w h)

-- | Tile images by overlapping them on a black canvas.
tileImages image1 image2 (x,y) = unsafePerformIO $
                               withImage image1 $ \i1 ->
                                withImage image2 $ \i2 ->
                                 creatingImage ({#call simpleMergeImages#}
                                                i1 i2 x y)
-- | Blit image2 onto image1.
blitFix = blit
blit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call plainBlit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = x+w2>w1 || y+h2>h1 || x<0 || y<0

-- | blit multiple tiles into one image
blitM :: (Int,Int) -> [((Int,Int),Image)] -> Image
blitM (rw,rh) imgs = resultPic
    where
     resultPic = unsafePerformIO $ do
                    r <- createImage32F (fromIntegral rw,fromIntegral rh) 1
                    sequence_ [blit r i (fromIntegral x, fromIntegral y)
                              | ((x,y),i) <- imgs ]
                    return r

subPixelBlit
  :: Image -> Image -> (CDouble, CDouble) -> IO ()

subPixelBlit image1 image2 (x,y)
    | badSizes  = error $ "Bad blit sizes: " ++ show [(w1,h1),(w2,h2)]++"<-"++show (x,y)
    | otherwise = withImage image1 $ \i1 ->
                   withImage image2 $ \i2 ->
                    ({#call subpixel_blit#} i1 i2 y x)
    where
     ((w1,h1),(w2,h2)) = (getSize image1,getSize image2)
     badSizes = ceiling x+w2>w1 || ceiling y+h2>h1 || x<0 || y<0

safeBlit i1 i2 (x,y) = unsafePerformIO $ do
                  res <- cloneImage i1-- createImage32F (getSize i1) 1
                  blit res i2 (x,y)
                  return res

-- | Blit image2 onto image1.
--   This uses an alpha channel bitmap for determining the regions where the image should be "blended" with
--   the base image.
blendBlit image1 image1Alpha image2 image2Alpha (x,y) =
                               withImage image1 $ \i1 ->
                                withImage image1Alpha $ \i1a ->
                                 withImage image2Alpha $ \i2a ->
                                  withImage image2 $ \i2 ->
                                   ({#call alphaBlit#} i1 i1a i2 i2a x y)

cloneImage img = withGenImage img $ \image ->
                    creatingImage ({#call cvCloneImage #} image)

withClone img fun = do
                result <- cloneImage img
                fun result
                return result

imageTo32F img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)
imageTo8Bit img = withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)
-- Ok. this is just the example why I need image types
withUniPtr with x fun = with x $ \y ->
                    fun (castPtr y)

withGenImage = withUniPtr withImage

-- Manipulating regions of interest:
setROI (x,y) (w,h) image = withImage image $ \i ->
                            {#call wrapSetImageROI#} i x y w h
resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

setCOI chnl image = withImage image $ \i ->
                            {#call cvSetImageCOI#} i (fromIntegral chnl)
resetCOI image = withImage image $ \i ->
                  {#call cvSetImageCOI#} i 0

getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI no image
    cres <- {#call wrapCreateImage32F#} w h 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

withIOROI pos size image op = do
            setROI pos size image
            x <- op
            resetROI image
            return x

withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image
                        resetROI image
                        return x

-- Manipulating image pixels
setPixel :: (CInt,CInt) -> CDouble -> Image -> IO ()
setPixel (x,y) v image = withGenImage image $ \img ->
                          {#call wrapSet32F2D#} img y x v

getPixel :: (CInt,CInt) -> Image -> CDouble
getPixel (x,y) image = unsafePerformIO $ withGenImage image $ \img ->
                          {#call wrapGet32F2D#} img y x

getAllPixels image =  [getPixel (i,j) image
                      | i <- [0..width-1 ]
                      , j <- [0..height-1]]
                    where
                     (width,height) = getSize image

getAllPixelsRowMajor image =  [getPixel (i,j) image
                              | j <- [0..height-1]
                              , i <- [0..width-1]
                              ]
                    where
                     (width,height) = getSize image

-- |Create a montage form given images (u,v) determines the layout and space the spacing
--  between images. Images are assumed to be the same size (determined by the first image)
montage :: (Int,Int) -> Int -> [Image] -> Image
montage (u',v') space' imgs = resultPic
    where
     space = fromIntegral space'
     (u,v) = (fromIntegral u', fromIntegral v')
     (rw,rh) = (u*xstep,v*ystep)
     (w,h) = getSize (head imgs)
     (xstep,ystep) = (fromIntegral space + w,fromIntegral space + h)
     edge = space`div`2
     resultPic = unsafePerformIO $ do
                    r <- createImage32F (rw,rh) 1
                    sequence_ [blit r i (edge +  x*xstep, edge + y*ystep)
                              | x <- [0..u-1], y <- [0..v-1]
                              | i <- imgs ]
                    return r


Add function sourceCompletionProviderUpdateInfo

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  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.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
   sourceCompletionProviderGetInfoWidget,
   sourceCompletionProviderGetActivation,
   sourceCompletionProviderMatch,
   sourceCompletionProviderUpdateInfo,
   sourceCompletionProviderPopulate,
   sourceCompletionProviderActivateProposal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
import Graphics.UI.Gtk.SourceView.Enums
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)

-- | Get a customized info widget to show extra information of a proposal. This allows for customized
-- widgets on a proposal basis, although in general providers will have the same custom widget for all
-- their proposals and proposal can be ignored.  The implementation of this function is optional. If
-- implemented, 'sourceCompletionProviderUpdateInfo' MUST also be implemented. If not
-- implemented, the default 'sourceCompletionProposalGetInfo' will be used to display extra
-- information about a 'SourceCompletionProposal'.
sourceCompletionProviderGetInfoWidget :: SourceCompletionProviderClass scp => scp
                                      -> SourceCompletionProposal -- ^ @proposal@ The currently selected 'SourceCompletionProposal'
                                     -> IO Widget -- ^ returns  a custom 'Widget' to show extra information about proposal.
sourceCompletionProviderGetInfoWidget scp proposal =
  makeNewObject mkWidget $
  {#call gtk_source_completion_provider_get_info_widget #}
    (toSourceCompletionProvider scp)
    proposal

-- | Get with what kind of activation the provider should be activated.
sourceCompletionProviderGetActivation :: SourceCompletionProviderClass scp => scp
                                      -> IO SourceCompletionActivation
sourceCompletionProviderGetActivation scp =
    liftM (toEnum . fromIntegral) $
    {#call gtk_source_completion_provider_get_activation #}
      (toSourceCompletionProvider scp)

-- | Get whether the provider match the context of completion detailed in context.
sourceCompletionProviderMatch :: SourceCompletionProviderClass scp => scp
                              -> SourceCompletionContext
                              -> IO Bool  -- ^ returns  'True' if provider matches the completion context, 'False' otherwise
sourceCompletionProviderMatch scp context =
  liftM toBool $
  {#call gtk_source_completion_provider_match #}
   (toSourceCompletionProvider scp)
   context

-- | Update extra information shown in info for proposal. This should be implemented if your provider
-- sets a custom info widget for proposal. This function MUST be implemented when
-- 'sourceCompletionProviderGetInfoWidget' is implemented.
sourceCompletionProviderUpdateInfo :: SourceCompletionProviderClass scp => scp
                                   -> SourceCompletionProposal
                                   -> SourceCompletionInfo
                                   -> IO ()
sourceCompletionProviderUpdateInfo scp proposal info =
  {#call gtk_source_completion_provider_update_info #}
    (toSourceCompletionProvider scp)
    proposal
    info

-- | Populate context with proposals from provider
sourceCompletionProviderPopulate :: SourceCompletionProviderClass scp => scp
                                 -> SourceCompletionContext
                                 -> IO ()
sourceCompletionProviderPopulate scp context =
  {#call gtk_source_completion_provider_populate #}
     (toSourceCompletionProvider scp)
     context

-- | Activate proposal at iter. When this functions returns 'False', the default activation of proposal
-- will take place which replaces the word at iter with the label of proposal.
sourceCompletionProviderActivateProposal :: SourceCompletionProviderClass scp => scp
                                         -> SourceCompletionProposal
                                         -> TextIter
                                         -> IO Bool -- ^ returns  'True' to indicate that the proposal activation has been handled, 'False' otherwise.
sourceCompletionProviderActivateProposal scp proposal iter =
  liftM toBool $
  {#call gtk_source_completion_provider_activate_proposal #}
    (toSourceCompletionProvider scp)
    proposal
    iter

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  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.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
   sourceCompletionProviderGetInfoWidget,
   sourceCompletionProviderGetActivation,
   sourceCompletionProviderMatch,
   sourceCompletionProviderPopulate,
   sourceCompletionProviderActivateProposal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
import Graphics.UI.Gtk.SourceView.Enums
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

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

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)

-- | Get a customized info widget to show extra information of a proposal. This allows for customized
-- widgets on a proposal basis, although in general providers will have the same custom widget for all
-- their proposals and proposal can be ignored.  The implementation of this function is optional. If
-- implemented, 'sourceCompletionProviderUpdateInfo' MUST also be implemented. If not
-- implemented, the default 'sourceCompletionProposalGetInfo' will be used to display extra
-- information about a 'SourceCompletionProposal'.
sourceCompletionProviderGetInfoWidget :: SourceCompletionProviderClass scp => scp
                                      -> SourceCompletionProposal -- ^ @proposal@ The currently selected 'SourceCompletionProposal'
                                     -> IO Widget -- ^ returns  a custom 'Widget' to show extra information about proposal.
sourceCompletionProviderGetInfoWidget scp proposal =
  makeNewObject mkWidget $
  {#call gtk_source_completion_provider_get_info_widget #}
    (toSourceCompletionProvider scp)
    proposal

-- | Get with what kind of activation the provider should be activated.
sourceCompletionProviderGetActivation :: SourceCompletionProviderClass scp => scp
                                      -> IO SourceCompletionActivation
sourceCompletionProviderGetActivation scp =
    liftM (toEnum . fromIntegral) $
    {#call gtk_source_completion_provider_get_activation #}
      (toSourceCompletionProvider scp)

-- | Get whether the provider match the context of completion detailed in context.
sourceCompletionProviderMatch :: SourceCompletionProviderClass scp => scp
                              -> SourceCompletionContext
                              -> IO Bool  -- ^ returns  'True' if provider matches the completion context, 'False' otherwise
sourceCompletionProviderMatch scp context =
  liftM toBool $
  {#call gtk_source_completion_provider_match #}
   (toSourceCompletionProvider scp)
   context

-- | Populate context with proposals from provider
sourceCompletionProviderPopulate :: SourceCompletionProviderClass scp => scp
                                 -> SourceCompletionContext
                                 -> IO ()
sourceCompletionProviderPopulate scp context =
  {#call gtk_source_completion_provider_populate #}
     (toSourceCompletionProvider scp)
     context

-- | Activate proposal at iter. When this functions returns 'False', the default activation of proposal
-- will take place which replaces the word at iter with the label of proposal.
sourceCompletionProviderActivateProposal :: SourceCompletionProviderClass scp => scp
                                         -> SourceCompletionProposal
                                         -> TextIter
                                         -> IO Bool -- ^ returns  'True' to indicate that the proposal activation has been handled, 'False' otherwise.
sourceCompletionProviderActivateProposal scp proposal iter =
  liftM toBool $
  {#call gtk_source_completion_provider_activate_proposal #}
    (toSourceCompletionProvider scp)
    proposal
    iter