remove redundant import

remove redundant import

Ignore-this: 95ef2ca2921f3e662e47b640fe570848

darcs-hash:20100116020805-dcabc-14953569c945c1cb40180a581adaa67f1a6be36d.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec
  (
    Fun(Fun),  -- need to export the data constructor for use by Module )=
    FunParam(..), FunAttribute(..),
    requires, setBlockShape, setSharedSize, setParams, launch
  )
  where

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

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))

-- System
import Foreign
import Foreign.C
import Control.Monad                            (zipWithM_)

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Kernel function parameters
--
data Storable a => FunParam a
    = IArg Int
    | FArg Float
    | VArg a
--  | TArg Texture

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the (x,y,z) dimensions of the thread blocks that are created when the
-- given kernel function is lanched
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- Invoke the kernel on a size (w,h) grid of blocks. Each block contains the
-- number of threads specified by a previous call to `setBlockShape'. The launch
-- may also be associated with a specific `Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Storable a => Fun -> [FunParam a] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg v)    = sizeOf v
    size (FArg v)    = sizeOf v
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Exec
-- Copyright : (c) 2009 Trevor L. McDonell
-- License   : BSD
--
-- Kernel execution control for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Exec
  (
    Fun(Fun),  -- need to export the data constructor for use by Module )=
    FunParam(..), FunAttribute(..),
    requires, setBlockShape, setSharedSize, setParams, launch
  )
  where

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

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))

-- System
import Foreign
import Foreign.C
import Data.Maybe
import Control.Monad                            (zipWithM_)

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

-- |
-- A @__global__@ device function
--
newtype Fun = Fun { useFun :: {# type CUfunction #}}

-- |
-- Function attributes
--
{# enum CUfunction_attribute as FunAttribute
    { underscoreToCase
    , MAX_THREADS_PER_BLOCK as MaxKernelThreadsPerBlock }
    with prefix="CU_FUNC_ATTRIBUTE" deriving (Eq, Show) #}

-- |
-- Kernel function parameters
--
data Storable a => FunParam a
    = IArg Int
    | FArg Float
    | VArg a
--  | TArg Texture

--------------------------------------------------------------------------------
-- Execution Control
--------------------------------------------------------------------------------

-- |
-- Returns the value of the selected attribute requirement for the given kernel
--
requires :: Fun -> FunAttribute -> IO Int
requires fn att = resultIfOk =<< cuFuncGetAttribute att fn

{# fun unsafe cuFuncGetAttribute
  { alloca-   `Int'          peekIntConv*
  , cFromEnum `FunAttribute'
  , useFun    `Fun'                       } -> `Status' cToEnum #}

-- |
-- Specify the (x,y,z) dimensions of the thread blocks that are created when the
-- given kernel function is lanched
--
setBlockShape :: Fun -> (Int,Int,Int) -> IO ()
setBlockShape fn (x,y,z) = nothingIfOk =<< cuFuncSetBlockShape fn x y z

{# fun unsafe cuFuncSetBlockShape
  { useFun `Fun'
  ,        `Int'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

-- |
-- Set the number of bytes of dynamic shared memory to be available to each
-- thread block when the function is launched
--
setSharedSize :: Fun -> Integer -> IO ()
setSharedSize fn bytes = nothingIfOk =<< cuFuncSetSharedSize fn bytes

{# fun unsafe cuFuncSetSharedSize
  { useFun   `Fun'
  , cIntConv `Integer' } -> `Status' cToEnum #}

-- |
-- Invoke the kernel on a size (w,h) grid of blocks. Each block contains the
-- number of threads specified by a previous call to `setBlockShape'. The launch
-- may also be associated with a specific `Stream'.
--
launch :: Fun -> (Int,Int) -> Maybe Stream -> IO ()
launch fn (w,h) mst =
  nothingIfOk =<< case mst of
    Nothing -> cuLaunchGridAsync fn w h (Stream nullPtr)
    Just st -> cuLaunchGridAsync fn w h st

{# fun unsafe cuLaunchGridAsync
  { useFun    `Fun'
  ,           `Int'
  ,           `Int'
  , useStream `Stream' } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Kernel function parameters
--------------------------------------------------------------------------------

-- |
-- Set the parameters that will specified next time the kernel is invoked
--
setParams :: Storable a => Fun -> [FunParam a] -> IO ()
setParams fn prs = do
  zipWithM_ (set fn) offsets prs
  nothingIfOk =<< cuParamSetSize fn (last offsets)
  where
    offsets = scanl (\a b -> a + size b) 0 prs

    size (IArg v)    = sizeOf v
    size (FArg v)    = sizeOf v
    size (VArg v)    = sizeOf v

    set f o (IArg v) = nothingIfOk =<< cuParamSeti f o v
    set f o (FArg v) = nothingIfOk =<< cuParamSetf f o v
    set f o (VArg v) = with v $ \p -> (nothingIfOk =<< cuParamSetv f o p (sizeOf v))

{# fun unsafe cuParamSetSize
  { useFun `Fun'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSeti
  { useFun `Fun'
  ,        `Int'
  ,        `Int' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetf
  { useFun `Fun'
  ,        `Int'
  ,        `Float' } -> `Status' cToEnum #}

{# fun unsafe cuParamSetv
  `Storable a' =>
  { useFun  `Fun'
  ,         `Int'
  , castPtr `Ptr a'
  ,         `Int'   } -> `Status' cToEnum #}


Update on/afterEdited to use new TreeIter

and to use connect_STRING_STRING__NONE rather than
connect_PTR_STRING__NONE. This is a different implementation than the
one in ModelView since the latter has a different type too. So this is
just an intrim implementation.

darcs-hash:20061208205259-b4c10-9bcbb4dd2c5335ab88cce8de4a1449650d96eec5.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) CellRendererText TreeView
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.7 $ from $Date: 2005/10/19 12:57:37 $
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- A 'CellRenderer' which displays a single-line text.
--
module Graphics.UI.Gtk.TreeList.CellRendererText (
-- * Detail
--
-- | This widget derives from 'CellRenderer'. It provides the
-- possibility to display some text by setting the 'Attribute'
-- 'cellText' to the column of a 'TreeModel' by means of
-- 'treeViewAddAttribute' from 'TreeModelColumn'.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'CellRenderer'
-- |               +----CellRendererText
-- |                     +----'CellRendererCombo'
-- @

-- * Types
  CellRendererText,
  CellRendererTextClass,
  castToCellRendererText,
  toCellRendererText,

-- * Constructors
  cellRendererTextNew,

-- * Attributes
  cellText,
  cellMarkup,
  cellBackground,
  cellForeground,
  cellEditable,

-- * Signals
  onEdited,
  afterEdited
  ) where

import Maybe	(fromMaybe)
import Monad	(liftM)

import System.Glib.FFI
import Graphics.UI.Gtk.Abstract.Object		(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
{#import Graphics.UI.Gtk.TreeList.TreeIter#}
import Graphics.UI.Gtk.General.Structs		(treeIterSize)
import Graphics.UI.Gtk.TreeList.CellRenderer	(Attribute(..))
import System.Glib.StoreValue			(GenericValue(..), TMType(..))

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

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

-- | Create a new CellRendererText object.
--
cellRendererTextNew :: IO CellRendererText
cellRendererTextNew =
  makeNewObject mkCellRendererText $
  liftM (castPtr :: Ptr CellRenderer -> Ptr CellRendererText) $
  {# call unsafe cell_renderer_text_new #}

-- helper function
--
strAttr :: [String] -> Attribute CellRendererText String
strAttr str = Attribute str [TMstring]
	        (return . (\x -> [x]) . GVstring . Just)
		(\[GVstring str] -> return (fromMaybe "" str))

mStrAttr :: [String] -> Attribute CellRendererText (Maybe String)
mStrAttr str = Attribute str [TMstring]
	        (return . (\x -> [x]) . GVstring)
		(\[GVstring str] -> return str)

--------------------
-- Properties

-- | Define the attribute that specifies the text to be
-- rendered.
--
cellText :: Attribute CellRendererText String
cellText  = strAttr ["text"]

-- | Define a markup string instead of a text.
--
cellMarkup :: Attribute CellRendererText String
cellMarkup  = strAttr ["markup"]

-- | A named color for the background paint.
--
cellBackground :: Attribute CellRendererText (Maybe String)
cellBackground  = mStrAttr ["background"]

-- | A named color for the foreground paint.
--
cellForeground :: Attribute CellRendererText (Maybe String)
cellForeground  = mStrAttr ["foreground"]

-- | Determines wether the content can be altered.
--
-- * If this flag is set, the user can alter the cell.
--
cellEditable :: Attribute CellRendererText (Maybe Bool)
cellEditable = Attribute ["editable","editable-set"] [TMboolean,TMboolean]
	         (\mb -> return $ case mb of
		   (Just bool) -> [GVboolean bool, GVboolean True]
		   Nothing     -> [GVboolean True, GVboolean False])
		 (\[GVboolean e, GVboolean s] -> return $
		   if s then Just e else Nothing)

-- | Emitted when the user finished editing a cell.
--
-- * This signal is not emitted when editing is disabled (see
--   'cellEditable') or when the user aborts editing.
--
onEdited, afterEdited :: TreeModelClass tm => CellRendererText -> tm ->
			 (TreeIter -> String -> IO ()) ->
			 IO (ConnectId CellRendererText)
onEdited cr tm user = connect_STRING_STRING__NONE "edited" False cr $
  \path string ->
  alloca $ \iterPtr ->
  withCString path $ \pathPtr -> do
  res <- {# call gtk_tree_model_get_iter_from_string #}
    (toTreeModel tm)
    iterPtr
    pathPtr
  if toBool res
    then do
      iter <- peek iterPtr
      user iter string
    else
      putStrLn "edited signal: invalid tree path"

afterEdited cr tm user = connect_STRING_STRING__NONE "edited" True cr $
  \path string ->
  alloca $ \iterPtr ->
  withCString path $ \pathPtr -> do
  res <- {# call gtk_tree_model_get_iter_from_string #}
    (toTreeModel tm)
    iterPtr
    pathPtr
  if toBool res
    then do
      iter <- peek iterPtr
      user iter string
    else
      putStrLn "edited signal: invalid tree path"

-- -*-haskell-*-
--  GIMP Toolkit (GTK) CellRendererText TreeView
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.7 $ from $Date: 2005/10/19 12:57:37 $
--
--  Copyright (C) 1999-2005 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- A 'CellRenderer' which displays a single-line text.
--
module Graphics.UI.Gtk.TreeList.CellRendererText (
-- * Detail
--
-- | This widget derives from 'CellRenderer'. It provides the
-- possibility to display some text by setting the 'Attribute'
-- 'cellText' to the column of a 'TreeModel' by means of
-- 'treeViewAddAttribute' from 'TreeModelColumn'.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Object'
-- |         +----'CellRenderer'
-- |               +----CellRendererText
-- |                     +----'CellRendererCombo'
-- @

-- * Types
  CellRendererText,
  CellRendererTextClass,
  castToCellRendererText,
  toCellRendererText,

-- * Constructors
  cellRendererTextNew,

-- * Attributes
  cellText,
  cellMarkup,
  cellBackground,
  cellForeground,
  cellEditable,

-- * Signals
  onEdited,
  afterEdited
  ) where

import Maybe	(fromMaybe)
import Monad	(liftM)

import System.Glib.FFI
import Graphics.UI.Gtk.Abstract.Object		(makeNewObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Signals#}
{#import Graphics.UI.Gtk.TreeList.TreeIter#}
import Graphics.UI.Gtk.General.Structs		(treeIterSize)
import Graphics.UI.Gtk.TreeList.CellRenderer	(Attribute(..))
import System.Glib.StoreValue			(GenericValue(..), TMType(..))

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

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

-- | Create a new CellRendererText object.
--
cellRendererTextNew :: IO CellRendererText
cellRendererTextNew =
  makeNewObject mkCellRendererText $
  liftM (castPtr :: Ptr CellRenderer -> Ptr CellRendererText) $
  {# call unsafe cell_renderer_text_new #}

-- helper function
--
strAttr :: [String] -> Attribute CellRendererText String
strAttr str = Attribute str [TMstring]
	        (return . (\x -> [x]) . GVstring . Just)
		(\[GVstring str] -> return (fromMaybe "" str))

mStrAttr :: [String] -> Attribute CellRendererText (Maybe String)
mStrAttr str = Attribute str [TMstring]
	        (return . (\x -> [x]) . GVstring)
		(\[GVstring str] -> return str)

--------------------
-- Properties

-- | Define the attribute that specifies the text to be
-- rendered.
--
cellText :: Attribute CellRendererText String
cellText  = strAttr ["text"]

-- | Define a markup string instead of a text.
--
cellMarkup :: Attribute CellRendererText String
cellMarkup  = strAttr ["markup"]

-- | A named color for the background paint.
--
cellBackground :: Attribute CellRendererText (Maybe String)
cellBackground  = mStrAttr ["background"]

-- | A named color for the foreground paint.
--
cellForeground :: Attribute CellRendererText (Maybe String)
cellForeground  = mStrAttr ["foreground"]

-- | Determines wether the content can be altered.
--
-- * If this flag is set, the user can alter the cell.
--
cellEditable :: Attribute CellRendererText (Maybe Bool)
cellEditable = Attribute ["editable","editable-set"] [TMboolean,TMboolean]
	         (\mb -> return $ case mb of
		   (Just bool) -> [GVboolean bool, GVboolean True]
		   Nothing     -> [GVboolean True, GVboolean False])
		 (\[GVboolean e, GVboolean s] -> return $
		   if s then Just e else Nothing)

-- | Emitted when the user finished editing a cell.
--
-- * This signal is not emitted when editing is disabled (see
--   'cellEditable') or when the user aborts editing.
--
onEdited, afterEdited :: TreeModelClass tm => CellRendererText -> tm ->
			 (TreeIter -> String -> IO ()) ->
			 IO (ConnectId CellRendererText)
onEdited cr tm user = connect_PTR_STRING__NONE "edited" False cr $
  \strPtr string ->
  mallocTreeIter >>= \iter ->
  {# call gtk_tree_model_get_iter_from_string #}
    (toTreeModel tm)
    iter
    strPtr
  >>= \res -> if toBool res then user iter string else
      putStrLn "edited signal: invalid tree path"

afterEdited cr tm user = connect_PTR_STRING__NONE "edited" True cr $
  \strPtr string ->
  mallocTreeIter >>= \iter ->
  {# call gtk_tree_model_get_iter_from_string #}
    (toTreeModel tm)
    iter
    strPtr
  >>= \res -> if toBool res then user iter string else
      putStrLn "edited signal: invalid tree path"


Fix documentation error.

Fix documentation error.

{-# LANGUAGE CPP, UndecidableInstances, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ExistentialQuantification #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Graphics.UI.FLTK.LowLevel.Window
    (
     CustomWindowFuncs(..),
     OptionalSizeRangeArgs(..),
     PositionSpec(..),
     WindowType(..),
     defaultCustomWindowFuncs,
     fillCustomWidgetFunctionStruct,
     defaultOptionalSizeRangeArgs,
     windowCustom,
     windowNew,
     windowMaker,
     currentWindow
     -- * Hierarchy
     --
     -- $hierarchy

     -- * Functions
     --
     -- $functions
    )
where
#include "Fl_C.h"
#include "Fl_WindowC.h"
#include "Fl_WidgetC.h"
#include "Fl_GroupC.h"
import Foreign
import Foreign.C
import Graphics.UI.FLTK.LowLevel.Fl_Types
import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
import Graphics.UI.FLTK.LowLevel.Utils
import Graphics.UI.FLTK.LowLevel.Dispatch
import qualified Data.Text as T
import Graphics.UI.FLTK.LowLevel.Hierarchy
import Graphics.UI.FLTK.LowLevel.Widget

import C2HS hiding (cFromEnum, toBool,cToEnum,cToBool)

#c
 enum WindowType {
   SingleWindowType = FL_WINDOWC,
   DoubleWindowType = FL_DOUBLE_WINDOWC
};
#endc
{#enum WindowType {} deriving (Show, Eq) #}

data PositionSpec = ByPosition Position
                  | forall a. (Parent a Widget) => ByWidget (Ref a)

data CustomWindowFuncs a =
    CustomWindowFuncs {
      flushCustom :: Maybe (Ref a -> IO ())
    }

data OptionalSizeRangeArgs = OptionalSizeRangeArgs {
      maxw :: Maybe Int,
      maxh :: Maybe Int,
      dw :: Maybe Int,
      dh :: Maybe Int,
      aspect :: Maybe Bool
    }

optionalSizeRangeArgsToStruct :: OptionalSizeRangeArgs -> IO (Ptr ())
optionalSizeRangeArgsToStruct args = do
  p <- mallocBytes {#sizeof fl_Window_size_range_args #}
  {#set fl_Window_size_range_args->maxw #} p $ maybe 0 fromIntegral (maxw args)
  {#set fl_Window_size_range_args->maxh #} p $ maybe 0 fromIntegral (maxh args)
  {#set fl_Window_size_range_args->dw #} p $ maybe 0 fromIntegral (dw args)
  {#set fl_Window_size_range_args->dh #} p $ maybe 0 fromIntegral (dh args)
  {#set fl_Window_size_range_args->aspect #} p $ maybe 0 fromBool (aspect args)
  return p

defaultOptionalSizeRangeArgs :: OptionalSizeRangeArgs
defaultOptionalSizeRangeArgs = OptionalSizeRangeArgs Nothing Nothing Nothing Nothing Nothing

fillCustomWindowFunctionStruct :: forall a. (Parent a Window) =>
                                  Ptr () ->
                                  CustomWindowFuncs a ->
                                  IO ()
fillCustomWindowFunctionStruct structPtr (CustomWindowFuncs _flush') =
  toCallbackPrim  `orNullFunPtr` _flush' >>= {#set fl_Window_Virtual_Funcs->flush#} structPtr

defaultCustomWindowFuncs :: forall a. (Parent a Window) => CustomWindowFuncs a
defaultCustomWindowFuncs = CustomWindowFuncs Nothing

{# fun Fl_Window_default_virtual_funcs as virtualFuncs' {} -> `Ptr ()' id #}
windowMaker :: forall a b. (Parent a Window, Parent b Widget) =>
               Size ->
               Maybe Position ->
               Maybe T.Text ->
               Maybe (Ref b -> IO ()) ->
               CustomWidgetFuncs b ->
               CustomWindowFuncs a ->
               (Int -> Int -> Ptr () -> IO (Ptr ())) ->
               (Int -> Int -> T.Text -> Ptr () -> IO (Ptr ())) ->
               (Int -> Int -> Int -> Int -> Ptr () -> IO (Ptr ())) ->
               (Int -> Int -> Int -> Int -> T.Text -> Ptr () -> IO (Ptr ())) ->
               IO (Ref a)
windowMaker (Size (Width w) (Height h))
            position
            title
            draw'
            customWidgetFuncs'
            customWindowFuncs'
            custom'
            customWithLabel'
            customXY'
            customXYWithLabel' =
     do
       p <- virtualFuncs'
       fillCustomWidgetFunctionStruct p draw' customWidgetFuncs'
       fillCustomWindowFunctionStruct p customWindowFuncs'
       case (position, title) of
        (Nothing, Nothing) -> custom' w h p >>= toRef
        (Just (Position (X x) (Y y)), Nothing) -> customXY' x y w h p >>= toRef
        (Just (Position (X x) (Y y)), (Just l')) -> customXYWithLabel' x y w h l' p >>= toRef
        (Nothing, (Just l')) -> customWithLabel' w h l' p >>= toRef

{# fun Fl_OverriddenWindow_New as overriddenWindowNew' {`Int',`Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenWindow_NewXY as overriddenWindowNewXY' {`Int',`Int', `Int', `Int', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenWindow_NewXY_WithLabel as overriddenWindowNewXYWithLabel' { `Int',`Int',`Int',`Int',unsafeToCString `T.Text', id `Ptr ()'} -> `Ptr ()' id #}
{# fun Fl_OverriddenWindow_New_WithLabel as overriddenWindowNewWithLabel' { `Int',`Int', unsafeToCString `T.Text', id `Ptr ()'} -> `Ptr ()' id #}
windowCustom :: Size                        -- ^ Size of this window
             -> Maybe Position              -- ^ Optional position of this window
             -> Maybe T.Text                -- ^ Optional label
             -> Maybe (Ref Window -> IO ()) -- ^ Optional table drawing routine
             -> CustomWidgetFuncs Window    -- ^ Custom widget overrides
             -> CustomWindowFuncs Window    -- ^ Custom window overrides
             -> IO (Ref Window)
windowCustom size position title draw' customWidgetFuncs' customWindowFuncs' =
  windowMaker
    size
    position
    title
    draw'
    customWidgetFuncs'
    customWindowFuncs'
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'

windowNew :: Size -> Maybe Position -> Maybe T.Text -> IO (Ref Window)
windowNew size position title =
  windowMaker
    size
    position
    title
    Nothing
    (defaultCustomWidgetFuncs :: CustomWidgetFuncs Window)
    (defaultCustomWindowFuncs :: CustomWindowFuncs Window)
    overriddenWindowNew'
    overriddenWindowNewWithLabel'
    overriddenWindowNewXY'
    overriddenWindowNewXYWithLabel'

{# fun Fl_Window_Destroy as windowDestroy' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (Destroy ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> windowDestroy' winPtr

{# fun Fl_Window_draw_super as drawSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (DrawSuper ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> drawSuper' windowPtr

{# fun Fl_Window_handle_super as handleSuper' { id `Ptr ()',`Int' } -> `Int' #}
instance (impl ~ (Event ->  IO (Either UnknownEvent ()))) => Op (HandleSuper ()) Window orig impl where
  runOp _ _ window event = withRef window $ \windowPtr -> handleSuper' windowPtr (fromIntegral (fromEnum event)) >>= return . successOrUnknownEvent

{# fun Fl_Window_resize_super as resizeSuper' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle -> IO ())) => Op (ResizeSuper ()) Window orig impl where
  runOp _ _ window rectangle =
    let (x_pos, y_pos, width, height) = fromRectangle rectangle
    in withRef window $ \windowPtr -> resizeSuper' windowPtr x_pos y_pos width height

{# fun Fl_Window_show_super as showSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (ShowWidgetSuper ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> showSuper' windowPtr

{# fun Fl_Window_hide_super as hideSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (HideSuper ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> hideSuper' windowPtr

{# fun Fl_Window_flush_super as flushSuper' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (FlushSuper ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> flushSuper' windowPtr

{# fun Fl_Window_show as windowShow' {id `Ptr ()'} -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (ShowWidget ()) Window orig impl where
  runOp _ _ window = withRef window (\p -> windowShow' p)

{#fun Fl_Window_handle as windowHandle' { id `Ptr ()', id `CInt' } -> `Int' #}
instance (impl ~ (Event -> IO (Either UnknownEvent ()))) => Op (Handle ()) Window orig impl where
  runOp _ _ window event = withRef window (\p -> windowHandle' p (fromIntegral . fromEnum $ event)) >>= return  . successOrUnknownEvent

{# fun Fl_Window_resize as resize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Rectangle -> IO ())) => Op (Resize ()) Window orig impl where
  runOp _ _ window rectangle = withRef window $ \windowPtr -> do
                                 let (x_pos,y_pos,w_pos,h_pos) = fromRectangle rectangle
                                 resize' windowPtr x_pos y_pos w_pos h_pos

{# fun Fl_Window_set_callback as windowSetCallback' {id `Ptr ()' , id `FunPtr CallbackWithUserDataPrim'} -> `()' supressWarningAboutRes #}
instance (impl ~ ((Ref orig -> IO ()) -> IO ())) => Op (SetCallback ()) Window orig impl where
  runOp _ _ window callback =
   withRef window $ (\p -> do
                           callbackPtr <- toCallbackPrimWithUserData callback
                           windowSetCallback' (castPtr p) callbackPtr)

{# fun Fl_Window_hide as hide' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Hide ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> hide' windowPtr

{# fun Fl_Window_changed as changed' { id `Ptr ()' } -> `Bool' cToBool #}
instance (impl ~ ( IO (Bool))) => Op (Changed ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> changed' winPtr

{# fun Fl_Window_fullscreen as fullscreen' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (MakeFullscreen ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> fullscreen' winPtr

{# fun Fl_Window_fullscreen_off as fullscreenOff' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_fullscreen_off_with_resize as fullscreenOffWithResize' { id `Ptr ()',`Int',`Int',`Int',`Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Maybe Rectangle ->  IO ())) => Op (FullscreenOff ()) Window orig impl where
  runOp _ _ win (Just rectangle) =
    withRef win $ \winPtr ->
        let (x_pos, y_pos, width, height) = fromRectangle rectangle
        in fullscreenOffWithResize' winPtr x_pos y_pos width height
  runOp _ _ win Nothing =
    withRef win $ \winPtr -> fullscreenOff' winPtr

{# fun Fl_Window_set_border as setBorder' { id `Ptr ()', fromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Bool ->  IO ())) => Op (SetBorder ()) Window orig impl where
  runOp _ _ win b = withRef win $ \winPtr -> setBorder' winPtr b

{# fun Fl_Window_clear_border as clearBorder' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (ClearBorder ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> clearBorder' winPtr

{# fun Fl_Window_border as border' { id `Ptr ()' } -> `Bool' toBool#}
instance (impl ~ ( IO (Bool))) => Op (GetBorder ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> border' winPtr

{# fun Fl_Window_set_override as setOverride' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SetOverride ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> setOverride' winPtr

{# fun Fl_Window_override as override' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetOverride ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> override' winPtr

{# fun Fl_Window_set_modal as setModal' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SetModal ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> setModal' winPtr

{# fun Fl_Window_modal as modal' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetModal ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> modal' winPtr

{# fun Fl_Window_set_non_modal as setNonModal' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SetNonModal ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> setNonModal' winPtr

{# fun Fl_Window_non_modal as nonModal' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (NonModal ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> nonModal' winPtr

{# fun Fl_Window_set_menu_window as setMenuWindow' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SetMenuWindow ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> setMenuWindow' winPtr

{# fun Fl_Window_menu_window as menuWindow' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetMenuWindow ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> menuWindow' winPtr

{# fun Fl_Window_set_tooltip_window as setTooltipWindow' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (SetTooltipWindow ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> setTooltipWindow' winPtr

{# fun Fl_Window_tooltip_window as tooltipWindow' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (GetTooltipWindow ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> tooltipWindow' winPtr

{# fun Fl_Window_hotspot_with_x_y as hotspotWithXY' { id `Ptr ()',`Int',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_hotspot_with_x_y_with_offscreen as hotspotWithXYWithOffscreen' { id `Ptr ()',`Int',`Int', fromBool `Bool' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_hotspot_with_widget as hotspotWithWidget' { id `Ptr ()',id `Ptr ()' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_hotspot_with_widget_with_offscreen as hotspotWithWidgetWithOffscreen' { id `Ptr ()',id `Ptr ()',fromBool `Bool' } -> `()' supressWarningAboutRes #}
instance (impl ~ (PositionSpec -> Maybe Bool -> IO ())) => Op (HotSpot ()) Window orig impl where
  runOp _ _ win positionSpec offscreen =
    withRef win $ \winPtr ->
            case (positionSpec, offscreen) of
              ((ByPosition (Position (X x) (Y y))), (Just offscreen')) ->
                  hotspotWithXYWithOffscreen' winPtr x y offscreen'
              ((ByPosition (Position (X x) (Y y))), Nothing) -> hotspotWithXY' winPtr x y
              ((ByWidget templateWidget), (Just offscreen')) ->
                  withRef templateWidget $ \templatePtr ->
                      hotspotWithWidgetWithOffscreen' winPtr templatePtr offscreen'
              ((ByWidget templateWidget), Nothing) ->
                  withRef templateWidget $ \templatePtr ->
                      hotspotWithWidget' winPtr templatePtr
{# fun Fl_Window_free_position as freePosition' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (FreePosition ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> freePosition' winPtr

{# fun Fl_Window_size_range as sizeRange' { id `Ptr ()',`Int',`Int' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_size_range_with_args as sizeRangeWithArgs' { id `Ptr ()',`Int',`Int', id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Int -> Int -> IO ())) => Op (SizeRange ()) Window orig impl where
  runOp _ _ win minw' minh' =
    withRef win $ \winPtr -> sizeRange' winPtr minw' minh'
instance (impl ~ (Int -> Int -> OptionalSizeRangeArgs ->  IO ())) => Op (SizeRangeWithArgs ()) Window orig impl where
  runOp _ _ win minw' minh' args =
    withRef win $ \winPtr -> do
      structPtr <- optionalSizeRangeArgsToStruct args
      sizeRangeWithArgs' winPtr minw' minh' structPtr

{# fun Fl_Window_label as label' { id `Ptr ()' } -> `T.Text' unsafeFromCString #}
instance (impl ~ ( IO T.Text)) => Op (GetLabel ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> label' winPtr

{# fun Fl_Window_iconlabel as iconlabel' { id `Ptr ()' } -> `T.Text' unsafeFromCString #}
instance (impl ~ ( IO T.Text)) => Op (GetIconlabel ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> iconlabel' winPtr

{# fun Fl_Window_set_label as setLabel' { id `Ptr ()',unsafeToCString `T.Text' } -> `()' supressWarningAboutRes #}
instance (impl ~ (T.Text ->  IO ())) => Op (SetLabel ()) Window orig impl where
  runOp _ _ win l' = withRef win $ \winPtr -> setLabel' winPtr l'

{# fun Fl_Window_set_iconlabel as setIconlabel' { id `Ptr ()',unsafeToCString `T.Text' } -> `()' supressWarningAboutRes #}
instance (impl ~ (T.Text ->  IO ())) => Op (SetIconlabel ()) Window orig impl where
  runOp _ _ win l' = withRef win $ \winPtr -> setIconlabel' winPtr l'

{# fun Fl_Window_set_label_with_iconlabel as setLabelWithIconlabel' { id `Ptr ()',unsafeToCString `T.Text',unsafeToCString `T.Text' } -> `()' supressWarningAboutRes #}
instance (impl ~ (T.Text -> T.Text ->  IO ())) => Op (SetLabelWithIconlabel ()) Window orig impl where
  runOp _ _ win label iconlabel = withRef win $ \winPtr -> setLabelWithIconlabel' winPtr label iconlabel

{# fun Fl_Window_copy_label as copyLabel' { id `Ptr ()',unsafeToCString `T.Text' } -> `()' supressWarningAboutRes #}
instance (impl ~ (T.Text ->  IO ())) => Op (CopyLabel ()) Window orig impl where
  runOp _ _ win a = withRef win $ \winPtr -> copyLabel' winPtr a

{# fun Fl_Window_xclass as xclass' { id `Ptr ()' } -> `T.Text' unsafeFromCString #}
instance (impl ~ ( IO T.Text)) => Op (GetXclass ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> xclass' winPtr

{# fun Fl_Window_set_xclass as setXclass' { id `Ptr ()',unsafeToCString `T.Text' } -> `()' supressWarningAboutRes #}
instance (impl ~ (T.Text ->  IO ())) => Op (SetXclass ()) Window orig impl where
  runOp _ _ win c = withRef win $ \winPtr -> setXclass' winPtr c

{# fun Fl_Window_icon as icon' { id `Ptr ()' } -> `Ptr ()' id #}
instance (impl ~ ( IO (Maybe (Ref Image)))) => Op (GetIcon ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> icon' winPtr >>= toMaybeRef

{# fun Fl_Window_set_icon as setIcon' { id `Ptr ()', id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (Parent a Image, impl ~ (Maybe( Ref a ) ->  IO ())) => Op (SetIcon ()) Window orig impl where
  runOp _ _ win bitmap = withRef win $ \winPtr -> withMaybeRef bitmap $ \bitmapPtr -> setIcon' winPtr bitmapPtr

{# fun Fl_Window_shown as shown' { id `Ptr ()' } -> `Bool' toBool #}
instance (impl ~ ( IO (Bool))) => Op (Shown ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> shown' winPtr

{# fun Fl_Window_iconize as iconize' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (Iconize ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> iconize' winPtr

{# fun Fl_Window_x_root as xRoot' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetXRoot ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> xRoot' winPtr

{# fun Fl_Window_y_root as yRoot' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetYRoot ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> yRoot' winPtr

{# fun Fl_Window_current as current' {  } -> `Ptr ()' id #}
currentWindow ::  (Parent a Window) => IO (Ref a)
currentWindow = current' >>= toRef

{# fun Fl_Window_make_current as makeCurrent' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ ( IO ())) => Op (MakeCurrent ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> makeCurrent' winPtr

{# fun Fl_Window_set_cursor_with_bg as setCursorWithBg' { id `Ptr ()',cFromEnum `Cursor',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_cursor_with_fg as setCursorWithFg' { id `Ptr ()',cFromEnum `Cursor',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_cursor_with_fg_bg as setCursorWithFgBg' { id `Ptr ()',cFromEnum `Cursor',cFromColor `Color',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_cursor as setCursor' { id `Ptr ()',cFromEnum `Cursor' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Cursor -> IO ())) => Op (SetCursor ()) Window orig impl where
  runOp _ _ win cursor =  withRef win $ \winPtr -> setCursor' winPtr cursor
instance (impl ~ (Cursor -> (Maybe Color, Maybe Color) ->  IO ())) => Op (SetCursorWithFgBg ()) Window orig impl where
  runOp _ _ win cursor fgbg =
    case fgbg of
      ((Just fg), (Just bg)) -> withRef win $ \winPtr -> setCursorWithFgBg' winPtr cursor fg bg
      (Nothing , (Just bg)) -> withRef win $ \winPtr -> setCursorWithBg' winPtr cursor bg
      ((Just fg), Nothing)  -> withRef win $ \winPtr -> setCursorWithFg' winPtr cursor fg
      (Nothing, Nothing)    -> withRef win $ \winPtr -> setCursor' winPtr cursor

{# fun Fl_Window_set_default_cursor_with_bg as setDefaultCursorWithBg' { id `Ptr ()',cFromEnum `CursorType',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_default_cursor_with_fg as setDefaultCursorWithFg' { id `Ptr ()',cFromEnum `CursorType',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_default_cursor_with_fg_bg as setDefaultCursorWithFgBg' { id `Ptr ()',cFromEnum `CursorType',cFromColor `Color',cFromColor `Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_set_default_cursor as setDefaultCursor' { id `Ptr ()',cFromEnum `CursorType' } -> `()' supressWarningAboutRes #}
instance (impl ~ (CursorType -> IO ())) => Op (SetDefaultCursor ()) Window orig impl where
  runOp _ _ win cursor = withRef win $ \winPtr -> setDefaultCursor' winPtr cursor
instance (impl ~ (CursorType -> (Maybe Color, Maybe Color) -> IO ())) => Op (SetDefaultCursorWithFgBg ()) Window orig impl where
  runOp _ _ win cursor fgbg =
    case fgbg of
      ((Just fg), (Just bg)) -> withRef win $ \winPtr -> setDefaultCursorWithFgBg' winPtr cursor fg bg
      (Nothing , (Just bg)) -> withRef win $ \winPtr -> setDefaultCursorWithBg' winPtr cursor bg
      ((Just fg), Nothing)  -> withRef win $ \winPtr -> setDefaultCursorWithFg' winPtr cursor fg
      (Nothing, Nothing)    -> withRef win $ \winPtr -> setDefaultCursor' winPtr cursor

{# fun Fl_Window_decorated_w as decoratedW' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetDecoratedW ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> decoratedW' winPtr

{# fun Fl_Window_decorated_h as decoratedH' { id `Ptr ()' } -> `Int' #}
instance (impl ~ ( IO (Int))) => Op (GetDecoratedH ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> decoratedH' winPtr

{# fun Fl_Window_draw_box as windowDrawBox' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_draw_box_with_tc as windowDrawBoxWithTC' { id `Ptr ()', cFromEnum `Boxtype', cFromColor`Color' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_draw_box_with_txywhc as windowDrawBoxWithTXywhC' { id `Ptr ()', cFromEnum `Boxtype', `Int',`Int',`Int',`Int', cFromColor `Color' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (DrawBox ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> windowDrawBox' windowPtr
instance (impl ~ (Boxtype -> Color -> Maybe Rectangle -> IO ())) => Op (DrawBoxWithBoxtype ()) Window orig impl where
  runOp _ _ window bx c Nothing =
              withRef window $ \windowPtr -> windowDrawBoxWithTC' windowPtr bx c
  runOp _ _ window bx c (Just r) =
              withRef window $ \windowPtr -> do
                let (x_pos,y_pos,w_pos,h_pos) = fromRectangle r
                windowDrawBoxWithTXywhC' windowPtr bx x_pos y_pos w_pos h_pos c
{# fun Fl_Window_draw_backdrop as windowDrawBackdrop' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
instance (impl ~ (IO ())) => Op (DrawBackdrop ()) Window orig impl where
  runOp _ _ window = withRef window $ \windowPtr -> windowDrawBackdrop' windowPtr

{# fun Fl_Window_draw_focus as windowDrawFocus' { id `Ptr ()' } -> `()' supressWarningAboutRes #}
{# fun Fl_Window_draw_focus_with_txywh as windowDrawFocusWithTXywh' { id `Ptr ()', cFromEnum `Boxtype', `Int', `Int', `Int', `Int' } -> `()' supressWarningAboutRes #}
instance (impl ~ (Maybe (Boxtype, Rectangle) -> IO ())) => Op (DrawFocus ()) Window orig impl where
  runOp _ _ window Nothing =
                withRef window $ \ windowPtr -> windowDrawFocus' windowPtr
  runOp _ _ window (Just (bx, r)) =
                withRef window $ \windowPtr -> do
                  let (x_pos,y_pos,w_pos,h_pos) = fromRectangle r
                  windowDrawFocusWithTXywh' windowPtr bx x_pos y_pos w_pos h_pos

{# fun Fl_Window_wait_for_expose as waitForExpose' { id `Ptr ()' } -> `()' #}
instance (impl ~ ( IO ())) => Op (WaitForExpose ()) Window orig impl where
  runOp _ _ win = withRef win $ \winPtr -> waitForExpose' winPtr

{# fun Fl_Widget_set_type as setType' { id `Ptr ()',`Word8' } -> `()' supressWarningAboutRes #}
instance (impl ~ (WindowType ->  IO ())) => Op (SetType ()) Window orig impl where
  runOp _ _ widget t = withRef widget $ \widgetPtr -> setType' widgetPtr (fromInteger $ toInteger $ fromEnum t)
{# fun Fl_Widget_type as type' { id `Ptr ()' } -> `Word8' #}
instance (impl ~ IO (WindowType)) => Op (GetType_ ()) Window orig impl where
  runOp _ _ widget = withRef widget $ \widgetPtr -> type' widgetPtr >>= return . toEnum . fromInteger . toInteger

-- $hierarchy
-- @
-- "Graphics.UI.FLTK.LowLevel.Widget"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Group"
--  |
--  v
-- "Graphics.UI.FLTK.LowLevel.Window"
-- @

-- $functions
-- @
-- changed :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- clearBorder :: 'Ref' 'Window' -> 'IO' ()
--
-- copyLabel :: 'Ref' 'Window' -> 'T.Text' -> 'IO' ()
--
-- destroy :: 'Ref' 'Window' -> 'IO' ()
--
-- drawBackdrop :: 'Ref' 'Window' -> 'IO' ()
--
-- drawBox :: 'Ref' 'Window' -> 'IO' ()
--
-- drawBoxWithBoxtype :: 'Ref' 'Window' -> 'Boxtype' -> 'Color' -> 'Maybe' 'Rectangle' -> 'IO' ()
--
-- drawFocus :: 'Ref' 'Window' -> 'Maybe' ('Boxtype', 'Rectangle') -> 'IO' ()
--
-- drawSuper :: 'Ref' 'Window' -> 'IO' ()
--
-- flushSuper :: 'Ref' 'Window' -> 'IO' ()
--
-- freePosition :: 'Ref' 'Window' -> 'IO' ()
--
-- fullscreenOff :: 'Ref' 'Window' -> 'Maybe' 'Rectangle' -> 'IO' ()
--
-- getBorder :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- getDecoratedH :: 'Ref' 'Window' -> 'IO' ('Int')
--
-- getDecoratedW :: 'Ref' 'Window' -> 'IO' ('Int')
--
-- getIcon :: 'Ref' 'Window' -> 'IO' ('Maybe' ('Ref' 'Image'))
--
-- getIconlabel :: 'Ref' 'Window' -> 'IO' 'T.Text'
--
-- getLabel :: 'Ref' 'Window' -> 'IO' 'T.Text'
--
-- getMenuWindow :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- getModal :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- getOverride :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- getTooltipWindow :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- getType_ :: 'Ref' 'Window' -> 'IO' ('WindowType')
--
-- getXRoot :: 'Ref' 'Window' -> 'IO' ('Int')
--
-- getXclass :: 'Ref' 'Window' -> 'IO' 'T.Text'
--
-- getYRoot :: 'Ref' 'Window' -> 'IO' ('Int')
--
-- handle :: 'Ref' 'Window' -> ('Event' -> 'IO' ('Either' 'UnknownEvent' ()))
--
-- handleSuper :: 'Ref' 'Window' -> 'Event' -> 'IO' ('Int')
--
-- hide :: 'Ref' 'Window' -> 'IO' ()
--
-- hideSuper :: 'Ref' 'Window' -> 'IO' ()
--
-- hotSpot :: 'Ref' 'Window' -> 'PositionSpec' -> 'Maybe' 'Bool' -> 'IO' ()
--
-- iconize :: 'Ref' 'Window' -> 'IO' ()
--
-- makeCurrent :: 'Ref' 'Window' -> 'IO' ()
--
-- makeFullscreen :: 'Ref' 'Window' -> 'IO' ()
--
-- nonModal :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- resize :: 'Ref' 'Window' -> 'Rectangle' -> 'IO' ()
--
-- resizeSuper :: 'Ref' 'Window' -> 'Rectangle' -> 'IO' ()
--
-- setBorder :: 'Ref' 'Window' -> 'Bool' -> 'IO' ()
--
-- setCallback :: 'Ref' 'Window' -> ('Ref' orig -> 'IO' ()) -> 'IO' ()
--
-- setCursor :: 'Ref' 'Window' -> 'Cursor' -> 'IO' ()
--
-- setCursorWithFgBg :: 'Ref' 'Window' -> 'Cursor' -> ('Maybe' 'Color', 'Maybe' 'Color') -> 'IO' ()
--
-- setDefaultCursor :: 'Ref' 'Window' -> 'CursorType' -> 'IO' ()
--
-- setDefaultCursorWithFgBg :: 'Ref' 'Window' -> 'CursorType' -> ('Maybe' 'Color', 'Maybe' 'Color') -> 'IO' ()
--
-- setIcon:: ('Parent' a 'Image') => 'Ref' 'Window' -> 'Maybe'( 'Ref' a ) -> 'IO' ()
--
-- setIconlabel :: 'Ref' 'Window' -> 'T.Text' -> 'IO' ()
--
-- setLabel :: 'Ref' 'Window' -> 'T.Text' -> 'IO' ()
--
-- setLabelWithIconlabel :: 'Ref' 'Window' -> 'T.Text' -> 'T.Text' -> 'IO' ()
--
-- setMenuWindow :: 'Ref' 'Window' -> 'IO' ()
--
-- setModal :: 'Ref' 'Window' -> 'IO' ()
--
-- setNonModal :: 'Ref' 'Window' -> 'IO' ()
--
-- setOverride :: 'Ref' 'Window' -> 'IO' ()
--
-- setTooltipWindow :: 'Ref' 'Window' -> 'IO' ()
--
-- setType :: 'Ref' 'Window' -> 'WindowType' -> 'IO' ()
--
-- setXclass :: 'Ref' 'Window' -> 'T.Text' -> 'IO' ()
--
-- showWidget :: 'Ref' 'Window' -> 'IO' ()
--
-- showWidgetSuper :: 'Ref' 'Window' -> 'IO' ()
--
-- shown :: 'Ref' 'Window' -> 'IO' ('Bool')
--
-- sizeRange :: 'Ref' 'Window' -> 'Int' -> 'Int' -> 'IO' ()
--
-- sizeRangeWithArgs :: 'Ref' 'Window' -> 'Int' -> 'Int' -> 'OptionalSizeRangeArgs' -> 'IO' ()
--
-- waitForExpose :: 'Ref' 'Window' -> 'IO' ()
-- @


Fixed compatability with opencv23 in CV.Transforms

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image as I
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp
import qualified CV.Matrix as M
import CV.Matrix (Matrix,withMatPtr)

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

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

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

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

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 cl <- I.create (getSize img)
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

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

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

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

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

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

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

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = map realToFrac . concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

#c
enum HomographyMethod {
     Default = 0,
     Ransac  = CV_RANSAC,
     LMeds   = CV_LMEDS
     };
#endc
{#enum HomographyMethod {}#}

getHomography' :: Matrix Float -> Matrix Float -> HomographyMethod -> Float -> Matrix Float
getHomography' srcPts dstPts method ransacThreshold =
    unsafePerformIO $ do
    hmg <- M.create (3,3) :: IO (Matrix Float)
    withMatPtr srcPts  $ \c_src ->
     withMatPtr dstPts $ \c_dst ->
     withMatPtr hmg    $ \c_hmg -> do
                          {#call cvFindHomography#}
                           (castPtr c_src)
                           (castPtr c_dst)
                           (castPtr c_hmg)
                           (fromIntegral $ fromEnum method)
                           (realToFrac ransacThreshold)
                           nullPtr
                          return hmg

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

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

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- I.create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- I.create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

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

-- | Enlargen the image so that its size is a power of two.
minEnlarge :: Image GrayScale D32 -> Image GrayScale D32
minEnlarge i = enlargeShadow (min (ceiling (logBase 2 (f w))) (ceiling (logBase 2 (f h)))) i
    where
     f = fromIntegral
     (w,h) = getSize i

-- | Calculate an infinite gaussian pyramid of an image while keeping track of
--   various corner cases and gotchas.
gaussianPyramid :: Image GrayScale D32 -> [Image GrayScale D32]
gaussianPyramid = iterate pyrDown' . minEnlarge
    where
     pyrDown' i = let (w,h) = getSize i
                  in if (w`div`2) <=1 || (h`div`2) <= 1 then i else pyrDown i

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

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

-- TODO: Could have wider type
-- |Enlargen the image so that its size is divisible by 2^n. Fill the area
--  outside the image with black.
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- I.create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

-- | Enlargen the image so that its size is is divisible by 2^n. Replicate
--   the border of the image.
enlargeShadow :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlargeShadow n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   withImage img $ \c_img ->
                    withImage i  $ \c_i   -> {#call blitShadow#} c_i c_img
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}
#ifdef OpenCV24
#c
enum LabelType {
     CCOMP = CV_DIST_LABEL_CCOMP
    ,PIXEL = CV_DIST_LABEL_PIXEL
};
#endc
{#enum LabelType {}#}
#endif

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

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

    return result

    -- TODO: Add handling for labels
    -- TODO: Add handling for custom masks

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, ScopedTypeVariables, PatternGuards, FlexibleContexts#-}
#include "cvWrapLEO.h"
-- |Various image transformations from opencv and other sources.
module CV.Transforms  where

import CV.Image as I
import Foreign.Ptr
import Foreign.C.Types
import Foreign.Marshal.Array
import System.IO.Unsafe
{#import CV.Image#}
import CV.ImageMathOp
import qualified CV.Matrix as M
import CV.Matrix (Matrix,withMatPtr)

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

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

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

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

-- |Mirror an image over a cardinal axis
flip :: CreateImage (Image c d) => MirrorAxis -> Image c d -> Image c d
flip axis img = unsafePerformIO $ do
                 cl <- I.create (getSize img)
                 withGenImage img $ \cimg ->
                  withGenImage cl $ \ccl -> do
                    {#call cvFlip#} cimg ccl (if axis == Vertical then 0 else 1)
                 return cl

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

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

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

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

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

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

-- |Apply a perspective transform to the image. The transformation 3x3 matrix is supplied as
--  a row ordered, flat, list.
perspectiveTransform :: Real a => Image c d -> [a] -> Image c d
perspectiveTransform img (map realToFrac -> [a1,a2,a3,a4,a5,a6,a7,a8,a9])
    = unsafePerformIO $
       withImage img $ \cimg -> creatingImage $ {#call wrapPerspective#} cimg a1 a2 a3 a4 a5 a6 a7 a8 a9

-- |Find a homography between two sets of points in. The resulting 3x3 matrix is returned as a list.
getHomography srcPts dstPts =
    unsafePerformIO $ withArray src $ \c_src ->
                       withArray dst $ \c_dst ->
                        allocaArray (3*3) $ \c_hmg -> do
                         {#call findHomography#} c_src c_dst (fromIntegral $ length srcPts) c_hmg
                         peekArray (3*3) c_hmg
    where
     flatten = map realToFrac . concatMap (\(a,b) -> [a,b])
     src = flatten srcPts
     dst = flatten dstPts

#c
enum HomographyMethod {
     Default = 0,
     Ransac  = CV_RANSAC,
     LMeds   = CV_LMEDS
     };
#endc
{#enum HomographyMethod {}#}

getHomography' :: Matrix Float -> Matrix Float -> HomographyMethod -> Float -> Matrix Float
getHomography' srcPts dstPts method ransacThreshold =
    unsafePerformIO $ do
    hmg <- M.create (3,3) :: IO (Matrix Float)
    withMatPtr srcPts  $ \c_src ->
     withMatPtr dstPts $ \c_dst ->
     withMatPtr hmg    $ \c_hmg -> do
                          {#call cvFindHomography#}
                           (castPtr c_src)
                           (castPtr c_dst)
                           (castPtr c_hmg)
                           (fromIntegral $ fromEnum method)
                           (realToFrac ransacThreshold)
                           nullPtr
                          return hmg

--- Pyramid transforms
-- |Return a copy of an image with an even size
evenize :: Image channels depth -> Image channels depth
evenize img = if (odd w || odd h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call makeEvenUp#} cImg
              else img
    where
     (w,h)  = getSize img

-- |Return a copy of an image with an odd size
oddize :: Image channels depth -> Image channels depth
oddize img = if (even w || even h)
              then
                unsafePerformIO $
                 creatingImage $
                  withGenImage img $ \cImg -> {#call padUp#} cImg (toI $ even w) (toI $ even h)
              else img
    where
     toI True = 1
     toI False = 0
     (w,h)  = getSize img

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

cv_Gaussian = 7
-- |Downsize image by 50% efficiently. Image dimensions must be even.
pyrDown ::(CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrDown image = unsafePerformIO $ do
                 res <- I.create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrDown#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x`div`2,y`div`2)
                (x,y) = getSize image

-- |Enlarge image to double in each dimension. Used to recover pyramidal layers
pyrUp :: (CreateImage (Image GrayScale a)) => Image GrayScale a -> Image GrayScale a
pyrUp image = unsafePerformIO $ do
                 res <- I.create size
                 withGenImage image $ \cImg ->
                   withGenImage res $ \cResImg ->
                     {#call cvPyrUp#} cImg cResImg cv_Gaussian
                 return res
            where
                size = (x*2,y*2)
                (x,y) = getSize image

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

-- | Enlargen the image so that its size is a power of two.
minEnlarge :: Image GrayScale D32 -> Image GrayScale D32
minEnlarge i = enlargeShadow (min (ceiling (logBase 2 (f w))) (ceiling (logBase 2 (f h)))) i
    where
     f = fromIntegral
     (w,h) = getSize i

-- | Calculate an infinite gaussian pyramid of an image while keeping track of
--   various corner cases and gotchas.
gaussianPyramid :: Image GrayScale D32 -> [Image GrayScale D32]
gaussianPyramid = iterate pyrDown' . minEnlarge
    where
     pyrDown' i = let (w,h) = getSize i
                  in if (w`div`2) <=1 || (h`div`2) <= 1 then i else pyrDown i

-- |Calculate the laplacian pyramid of an image up to the nth level.
--  Notice that the image size must be divisible by 2^n or opencv
--  will abort (TODO!)
laplacianPyramid :: Int -> Image GrayScale D32 -> [Image GrayScale D32]
laplacianPyramid depth image = reverse laplacian
  where
   downs :: [Image GrayScale D32] = take depth $ iterate pyrDown (image)
   upsampled :: [Image GrayScale D32] = map pyrUp (tail downs)
   laplacian = zipWith (#-) downs upsampled ++ [last downs]

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

-- TODO: Could have wider type
-- |Enlargen the image so that its size is divisible by 2^n. Fill the area
--  outside the image with black.
enlarge :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlarge n img =  unsafePerformIO $ do
                   i <- I.create (w2,h2)
                   blit i img (0,0)
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

-- | Enlargen the image so that its size is is divisible by 2^n. Replicate
--   the border of the image.
enlargeShadow :: Int -> Image GrayScale D32 -> Image GrayScale D32
enlargeShadow n img =  unsafePerformIO $ do
                   i <- create (w2,h2)
                   withImage img $ \c_img ->
                    withImage i  $ \c_i   -> {#call blitShadow#} c_i c_img
                   return i
    where
     (w,h) = getSize img
     (w2,h2) = (pad w, pad h)
     pad x = x + (np - x `mod` np)
     np = 2^n

#c
enum DistanceType {
     C =  CV_DIST_C
    ,L1 =  CV_DIST_L1
    ,L2 =  CV_DIST_L2
};
#endc
{#enum DistanceType {}#}

#c
enum LabelType {
     CCOMP = CV_DIST_LABEL_CCOMP
    ,PIXEL = CV_DIST_LABEL_PIXEL
};
#endc
{#enum LabelType {}#}

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

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


Document the Matrix representation

Document the Matrix representation

darcs-hash:20060505180256-b4c10-c2ffbad6e77f939bf6ca9120b04bbdfeb4dfa589.gz

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

-- | Representation of a 2-D affine transformation as a matrix.
--
-- The 'Matrix' type actually represents as 3x3 matrix but with some elements
-- are constant and so are not included. Specifically if we assume that our
-- coordinates are row vectors then correspondence is:
--
-- >    Matrix xx yx xy yy x0 y0
-- > ==
-- >    / xx yx 0 \
-- >    | xy yy 0 |
-- >    \ x0 y0 1 /
--
-- and the matrix operates on @(x,y)@ coordinates:
--
-- > (x y 1) / xx yx 0 \  = (x' y' 1)
-- >         | xy yy 0 |  where x' = xx * x + xy * y + x0
-- >         \ x0 y0 1 /        y' = yx * x + yy * y + y0
--
data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yx - xy*yy

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Matrix
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Matrix math
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.Matrix (
    Matrix(Matrix)
  , MatrixPtr
  , identity
  , translate
  , scale
  , rotate
  , transformDistance
  , transformPoint
  , scalarMultiply
  , adjoint
  , invert
  ) where

import Foreign hiding (rotate)
import CForeign

data Matrix = Matrix { xx :: !Double, yx :: !Double,
                       xy :: !Double, yy :: !Double,
                       x0 :: !Double, y0 :: !Double }
  deriving (Show, Eq)

{#pointer *cairo_matrix_t as MatrixPtr -> Matrix#}

instance Storable Matrix where
  sizeOf _ = {#sizeof cairo_matrix_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    xx <- {#get cairo_matrix_t->xx#} p
    yx <- {#get cairo_matrix_t->yx#} p
    xy <- {#get cairo_matrix_t->xy#} p
    yy <- {#get cairo_matrix_t->yy#} p
    x0 <- {#get cairo_matrix_t->x0#} p
    y0 <- {#get cairo_matrix_t->y0#} p
    return $ Matrix (realToFrac xx) (realToFrac yx)
                    (realToFrac xy) (realToFrac yy)
                    (realToFrac x0) (realToFrac y0)

  poke p (Matrix xx yx xy yy x0 y0) = do
    {#set cairo_matrix_t->xx#} p (realToFrac xx)
    {#set cairo_matrix_t->yx#} p (realToFrac yx)
    {#set cairo_matrix_t->xy#} p (realToFrac xy)
    {#set cairo_matrix_t->yy#} p (realToFrac yy)
    {#set cairo_matrix_t->x0#} p (realToFrac x0)
    {#set cairo_matrix_t->y0#} p (realToFrac y0)
    return ()

instance Num Matrix where
  (*) (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
    Matrix (xx * xx' + yx * xy')
           (xx * yx' + yx * yy')
           (xy * xx' + yy * xy')
           (xy * yx' + yy * yy')
           (x0 * xx' + y0 * xy' + x0')
           (x0 * yx' + y0 * yy' + y0')

  (+) = pointwise2 (+)
  (-) = pointwise2 (-)

  negate = pointwise negate
  abs    = pointwise abs
  signum = pointwise signum

  -- this definition of fromInteger means that 2*m = scale 2 m
  -- and it means 1 = identity
  fromInteger n = Matrix (fromInteger n) 0 0 (fromInteger n) 0 0

{-# INLINE pointwise #-}
pointwise f (Matrix xx yx xy yy x0 y0) =
  Matrix (f xx) (f yx) (f xy) (f yy) (f x0) (f y0)

{-# INLINE pointwise2 #-}
pointwise2 f (Matrix xx yx xy yy x0 y0) (Matrix xx' yx' xy' yy' x0' y0') =
  Matrix (f xx xx') (f yx yx') (f xy xy') (f yy yy') (f x0 x0') (f y0 y0')

identity :: Matrix
identity = Matrix 1 0 0 1 0 0

translate :: Double -> Double -> Matrix -> Matrix
translate tx ty m = m * (Matrix 1 0 0 1 tx ty)

scale :: Double -> Double -> Matrix -> Matrix
scale sx sy m = m * (Matrix sx 0 0 sy 0 0)

rotate :: Double -> Matrix -> Matrix
rotate r m = m * (Matrix c s (-s) c 0 0)
  where s = sin r
        c = cos r

transformDistance :: Matrix -> (Double,Double) -> (Double,Double)
transformDistance (Matrix xx yx xy yy _ _) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy
        newY = yx * dx + yy * dy

transformPoint :: Matrix -> (Double,Double) -> (Double,Double)
transformPoint (Matrix xx yx xy yy x0 y0) (dx,dy) =
  newX `seq` newY `seq` (newX,newY)
  where newX = xx * dx + xy * dy + x0
        newY = yx * dx + yy * dy + y0

scalarMultiply :: Double -> Matrix -> Matrix
scalarMultiply scalar = pointwise (*scalar)

adjoint :: Matrix -> Matrix
adjoint (Matrix a b c d tx ty) =
  Matrix d (-b) (-c) a (c*ty - d*tx) (b*tx - a*ty)

invert :: Matrix -> Matrix
invert m@(Matrix xx yx xy yy _ _) = scalarMultiply (recip det) $ adjoint m
  where det = xx*yx - xy*yy


Add function sourceCompletionProviderMatch

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

{-# 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,
   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)

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