Add Haddocks

Add Haddocks

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module NanoVG.Internal
  ( FileName(..)
  , Image(..)
  , Font(..)
  , Context(..)
  , Transformation(..)
  , Extent(..)
  , Color(..)
  , Paint(..)
  , Bounds(..)
  , GlyphPosition(..)
  , GlyphPositionPtr
  , TextRow(..)
  , TextRowPtr
  , CreateFlags(..)
  , Solidity(..)
  , LineCap(..)
  , Align(..)
  , Winding(..)
  , beginFrame
  , cancelFrame
  , endFrame
  -- * Color utils
  , rgb
  , rgbf
  , rgba
  , rgbaf
  , lerpRGBA
  , transRGBA
  , transRGBAf
  , hsl
  , hsla
  -- * State handling
  , save
  , restore
  , reset
  -- * Render styles
  , strokeColor
  , strokePaint
  , fillColor
  , fillPaint
  , miterLimit
  , strokeWidth
  , lineCap
  , lineJoin
  , globalAlpha
  -- * Transforms
  , resetTransform
  , transform
  , translate
  , rotate
  , skewX
  , skewY
  , scale
  , currentTransform
  , transformIdentity
  , transformTranslate
  , transformScale
  , transformRotate
  , transformSkewX
  , transformSkewY
  , transformMultiply
  , transformPremultiply
  , transformInverse
  , transformPoint
  , degToRad
  , radToDeg
  -- * Images
  , createImage
  , createImageMem
  , createImageRGBA
  , updateImage
  , imageSize
  , deleteImage
  -- * Paints
  , linearGradient
  , boxGradient
  , radialGradient
  , imagePattern
  -- * Scissoring
  , scissor
  , intersectScissor
  , resetScissor
  -- * Paths
  , beginPath
  , moveTo
  , lineTo
  , bezierTo
  , quadTo
  , arcTo
  , closePath
  , pathWinding
  , arc
  , rect
  , roundedRect
  , ellipse
  , circle
  , fill
  , stroke
  -- * Text
  , createFont
  , createFontMem
  , findFont
  , fontSize
  , fontBlur
  , textLetterSpacing
  , textLineHeight
  , textAlign
  , fontFaceId
  , fontFace
  , text
  , textBox
  , textBounds
  , textBoxBounds
  , textGlyphPositions
  , textMetrics
  , textBreakLines
  -- * GL
  , createGL3
  , deleteGL3
  , createImageFromHandleGL3
  , imageHandleGL3
  ) where

import           Data.Bits hiding (rotate)
import           Data.ByteString hiding (null)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Word
import           Foreign.C.String (CString)
import           Foreign.C.Types
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           Linear.Matrix
import           Linear.V2
import           Linear.V3
import           Linear.V4
import           Prelude hiding (null)

-- For now only the GL3 backend is supported
#define NANOVG_GL3
-- We need to include this to define GLuint
#include "GL/glew.h"
#include "nanovg.h"
#include "nanovg_gl.h"
#include "nanovg_wrapper.h"

-- | Marshal a Haskell string into a NUL terminated C string using temporary storage.
withCString :: T.Text -> (CString -> IO b) -> IO b
withCString t = useAsCString (T.encodeUtf8 t)

-- | Wrapper around 'useAsCStringLen' that uses 'CUChar's
useAsCStringLen' :: ByteString -> ((Ptr CUChar,CInt) -> IO a) -> IO a
useAsCStringLen' bs f = useAsCStringLen bs (\(ptr,len) -> f (castPtr ptr,fromIntegral len))

-- | Wrapper around 'useAsCStringLen'' that discards the length
useAsPtr :: ByteString -> (Ptr CUChar -> IO a) -> IO a
useAsPtr bs f = useAsCStringLen' bs (f . fst)

-- | Marshalling helper for a constant zero
zero :: Num a => (a -> b) -> b
zero f = f 0

-- | Marshalling helper for a constant 'nullPtr'
null :: (Ptr a -> b) -> b
null f = f nullPtr

-- | Newtype to avoid accidental use of strings
newtype FileName = FileName { unwrapFileName :: T.Text }

-- | Newtype to avoid accidental use of ints
newtype Image = Image {imageHandle :: CInt} deriving (Show,Read,Eq,Ord)

-- | Newtype to avoid accidental use of ints
newtype Font = Font {fontHandle :: CInt} deriving (Show,Read,Eq,Ord)

-- | Opaque context that needs to be passed around
{#pointer *NVGcontext as Context newtype#}

-- | Affine matrix
--
-- > [sx kx tx]
-- > [ky sy ty]
-- > [ 0  0  1]
newtype Transformation = Transformation (M23 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Transformation where
  sizeOf _ = sizeOf (0 :: CFloat) * 6
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peek p'
       b <- peekElemOff p' 1
       c <- peekElemOff p' 2
       d <- peekElemOff p' 3
       e <- peekElemOff p' 4
       f <- peekElemOff p' 5
       pure (Transformation
               (V2 (V3 a c e)
                   (V3 b d f)))
  poke p (Transformation (V2 (V3 a c e) (V3 b d f))) =
    do let p' = castPtr p :: Ptr CFloat
       poke p' a
       pokeElemOff p' 1 b
       pokeElemOff p' 2 c
       pokeElemOff p' 3 d
       pokeElemOff p' 4 e
       pokeElemOff p' 5 f

newtype Extent = Extent (V2 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Extent where
  sizeOf _ = sizeOf (0 :: CFloat) * 2
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peekElemOff p' 0
       b <- peekElemOff p' 1
       pure (Extent (V2 a b))
  poke p (Extent (V2 a b)) =
    do let p' = castPtr p :: Ptr CFloat
       pokeElemOff p' 0 a
       pokeElemOff p' 1 b

-- | rgba
data Color = Color !CFloat !CFloat !CFloat !CFloat deriving (Show,Read,Eq,Ord)

{#pointer *NVGcolor as ColorPtr -> Color#}

instance Storable Color where
  sizeOf _ = sizeOf (0 :: CFloat) * 4
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       r <- peek p'
       g <- peekElemOff p' 1
       b <- peekElemOff p' 2
       a <- peekElemOff p' 3
       pure (Color r g b a)
  poke p (Color r g b a) =
    do let p' = castPtr p :: Ptr CFloat
       poke p' r
       pokeElemOff p' 1 g
       pokeElemOff p' 2 b
       pokeElemOff p' 3 a

data Paint =
  Paint {xform :: Transformation
        ,extent :: Extent
        ,radius :: !CFloat
        ,feather :: !CFloat
        ,innerColor :: !Color
        ,outerColor :: !Color
        ,image :: !Image} deriving (Show,Read,Eq,Ord)

{#pointer *NVGpaint as PaintPtr -> Paint#}

instance Storable Paint where
  sizeOf _ = 76
  alignment _ = 4
  peek p =
    do xform <- peek (castPtr (p `plusPtr` {#offsetof NVGpaint->xform#}))
       extent <- peek (castPtr (p `plusPtr` {#offsetof NVGpaint->extent#}))
       radius <- {#get NVGpaint->radius#} p
       feather <- {#get NVGpaint->feather#} p
       innerColor <- peek (castPtr (p `plusPtr` 40))
       outerColor <- peek (castPtr (p `plusPtr` 56))
       image <- peek (castPtr (p `plusPtr` 72))
       pure (Paint xform extent radius feather innerColor outerColor (Image image))
  poke p (Paint{..}) =
    do poke (castPtr (p `plusPtr` {#offsetof NVGpaint->xform#})) xform
       poke (castPtr (p `plusPtr` {#offsetof NVGpaint->extent#})) extent
       {#set NVGpaint->radius#} p radius
       {#set NVGpaint->feather#} p feather
       poke (castPtr (p `plusPtr` 40)) innerColor
       poke (castPtr (p `plusPtr` 56)) outerColor
       poke (castPtr (p `plusPtr` 72)) (imageHandle image)

{#enum NVGwinding as Winding
         {} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGsolidity as Solidity
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGlineCap as LineCap
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGalign as Align
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

data GlyphPosition =
     GlyphPosition { -- | Pointer of the glyph in the input string.
                     str :: !(Ptr CChar)
                     -- | The x-coordinate of the logical glyph position.
                   , glyphX :: !CFloat
                     -- | The left bound of the glyph shape.
                   , glyphPosMinX :: !CFloat
                     -- | The right bound of the glyph shape.
                   , glyphPosMaxX :: !CFloat} deriving (Show,Eq,Ord)

{#pointer *NVGglyphPosition as GlyphPositionPtr -> GlyphPosition#}

instance Storable GlyphPosition where
  sizeOf _ = 24
  alignment _ = {#alignof NVGglyphPosition#}
  peek p =
    do str <- {#get NVGglyphPosition->str#} p
       x <- {#get NVGglyphPosition->x#} p
       minx <- {#get NVGglyphPosition->minx#} p
       maxx <- {#get NVGglyphPosition->maxx#} p
       pure (GlyphPosition str x minx maxx)
  poke p (GlyphPosition str x minx maxx) =
    do {#set NVGglyphPosition->str#} p str
       {#set NVGglyphPosition->x#} p x
       {#set NVGglyphPosition->minx#} p minx
       {#set NVGglyphPosition->maxx#} p maxx

data TextRow =
  TextRow { -- | Pointer to the input text where the row starts.
            start :: !(Ptr CChar)
            -- | Pointer to the input text where the row ends (one past the last character).
          , end :: !(Ptr CChar)
            -- | Pointer to the beginning of the next row.
          , next :: !(Ptr CChar)
            -- | Logical width of the row.
          , width :: !CFloat
            -- | Actual bounds of the row. Logical with and bounds can differ because of kerning and some parts over extending.
          , textRowMinX :: !CFloat
          , textRowMaxX :: !CFloat}
  deriving (Show,Eq,Ord)

instance Storable TextRow where
  sizeOf _ = 40
  alignment _ = {#alignof NVGtextRow#}
  peek p =
    do start <- {#get NVGtextRow->start#} p
       end <- {#get NVGtextRow->end#} p
       next <- {#get NVGtextRow->next#} p
       width <- {#get NVGtextRow->width#} p
       minX <- {#get NVGtextRow->minx#} p
       maxX <- {#get NVGtextRow->maxx#} p
       pure (TextRow start end next width minX maxX)
  poke p (TextRow {..}) =
    do {#set NVGtextRow->start#} p start
       {#set NVGtextRow->end#} p end
       {#set NVGtextRow->next#} p next
       {#set NVGtextRow->width#} p width
       {#set NVGtextRow->minx#} p textRowMinX
       {#set NVGtextRow->maxx#} p textRowMaxX

{#pointer *NVGtextRow as TextRowPtr -> TextRow#}

{#enum NVGimageFlags as ImageFlags
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

-- | Begin drawing a new frame
--
-- Calls to nanovg drawing API should be wrapped in 'beginFrame' & 'endFrame'.
--
-- 'beginFrame' defines the size of the window to render to in relation currently
-- set viewport (i.e. glViewport on GL backends). Device pixel ration allows to
-- control the rendering on Hi-DPI devices.
--
-- For example, GLFW returns two dimension for an opened window: window size and
-- frame buffer size. In that case you would set windowWidth/Height to the window size
-- devicePixelRatio to: frameBufferWidth / windowWidth.
{#fun unsafe nvgBeginFrame as beginFrame
        {`Context',`CInt',`CInt',`Float'} -> `()'#}

-- | Cancels drawing the current frame.
{#fun unsafe nvgCancelFrame as cancelFrame
        {`Context'} -> `()'#}

-- | Ends drawing flushing remaining render state.
{#fun unsafe nvgEndFrame as endFrame
        {`Context'} -> `()'#}

-- | Returns a color value from red, green, blue values. Alpha will be set to 255 (1.0f).
{#fun pure unsafe nvgRGB_ as rgb
        {id`CUChar',id`CUChar',id`CUChar',alloca-`Color'peek*} -> `()'#}

-- | Returns a color value from red, green, blue values. Alpha will be set to 1.0f.
{#fun pure unsafe nvgRGBf_ as rgbf
        {`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

-- | Returns a color value from red, green, blue and alpha values.
{#fun pure unsafe nvgRGBA_ as rgba
        {id`CUChar',id`CUChar',id`CUChar',id`CUChar',alloca-`Color'peek*} -> `()'#}

-- | Returns a color value from red, green, blue and alpha values.
{#fun pure unsafe nvgRGBAf_ as rgbaf
        {`CFloat',`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

-- | Linearly interpolates from color c0 to c1, and returns resulting color value.
{#fun pure unsafe nvgLerpRGBA_ as lerpRGBA
        {with*`Color',with*`Color',`CFloat',alloca-`Color'peek*} -> `()'#}

-- | Sets transparency of a color value.
{#fun pure unsafe nvgTransRGBA_ as transRGBA
        {with*`Color',id`CUChar',alloca-`Color'peek*} -> `()'#}

-- | Sets transparency of a color value.
{#fun pure unsafe nvgTransRGBAf_ as transRGBAf
        {with*`Color',`CFloat',alloca-`Color'peek*} -> `()'#}

-- | Returns color value specified by hue, saturation and lightness.
-- HSL values are all in range [0..1], alpha will be set to 255.
{#fun pure unsafe nvgHSL_ as hsl
        {`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

-- | Returns color value specified by hue, saturation and lightness and alpha.
-- HSL values are all in range [0..1], alpha in range [0..255]
{#fun pure unsafe nvgHSLA_ as hsla
        {`CFloat',`CFloat',`CFloat',id`CUChar',alloca-`Color'peek*} -> `()'#}

-- | Pushes and saves the current render state into a state stack.
-- A matching 'restore' must be used to restore the state.

{#fun unsafe nvgSave as save
        {`Context'} -> `()'#}

-- | Pops and restores current render state.
{#fun unsafe nvgRestore as restore
        {`Context'} -> `()'#}

-- | Resets current render state to default values. Does not affect the render state stack.
{#fun unsafe nvgReset as reset
        {`Context'} -> `()'#}

-- | Sets current stroke style to a solid color.
{#fun unsafe nvgStrokeColor_ as strokeColor
        {`Context',with*`Color'} -> `()'#}

-- | Sets current stroke style to a paint, which can be a one of the gradients or a pattern.
{#fun unsafe nvgStrokePaint_ as strokePaint
        {`Context',with*`Paint'} -> `()'#}

-- | Sets current fill style to a solid color.
{#fun unsafe nvgFillColor_ as fillColor
        {`Context',with*`Color'} -> `()'#}

-- | Sets current fill style to a paint, which can be a one of the gradients or a pattern.
{#fun unsafe nvgFillPaint_ as fillPaint
        {`Context',with*`Paint'} -> `()'#}

-- | Sets the miter limit of the stroke style.
-- Miter limit controls when a sharp corner is beveled.
{#fun unsafe nvgMiterLimit as miterLimit
        {`Context',`CFloat'} -> `()'#}

-- | Sets the stroke width of the stroke style.
{#fun unsafe nvgStrokeWidth as strokeWidth
        {`Context',`CFloat'} -> `()'#}

-- | Sets how the end of the line (cap) is drawn,
-- Can be one of: 'Butt' (default), 'Round', 'Square'.
{#fun unsafe nvgLineCap as lineCap
        {`Context',`LineCap'} -> `()'#}

-- | Sets how sharp path corners are drawn.
-- Can be one of 'Miter' (default), 'Round', 'Bevel.
{#fun unsafe nvgLineJoin as lineJoin
        {`Context',`LineCap'} -> `()'#}

-- | Sets the transparency applied to all rendered shapes.
-- Already transparent paths will get proportionally more transparent as well.
{#fun unsafe nvgGlobalAlpha as globalAlpha
        {`Context',`CFloat'} -> `()'#}

-- | Resets current transform to a identity matrix.
{#fun unsafe nvgResetTransform as resetTransform
        {`Context'} -> `()'#}

-- | Premultiplies current coordinate system by specified matrix.
-- The parameters are interpreted as matrix as follows:
--
-- > [a c e]
-- > [b d f]
-- > [0 0 1]
{#fun unsafe nvgTransform as transform
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Translates current coordinate system.
{#fun unsafe nvgTranslate as translate
        {`Context',`CFloat',`CFloat'} -> `()'#}

-- | Rotates current coordinate system. Angle is specified in radians.
{#fun unsafe nvgRotate as rotate
        {`Context',`CFloat'} -> `()'#}

-- | Skews the current coordinate system along X axis. Angle is specified in radians.
{#fun unsafe nvgSkewX as skewX
        {`Context',`CFloat'} -> `()'#}

-- | Skews the current coordinate system along Y axis. Angle is specified in radians.
{#fun unsafe nvgSkewY as skewY
        {`Context',`CFloat'} -> `()'#}

-- | Scales the current coordinate system.
{#fun unsafe nvgScale as scale
        {`Context',`CFloat',`CFloat'} -> `()'#}

peekTransformation :: Ptr CFloat -> IO Transformation
peekTransformation = peek . castPtr

allocaTransformation :: (Ptr CFloat -> IO b) -> IO b
allocaTransformation f = alloca (\(p :: Ptr Transformation) -> f (castPtr p))

withTransformation :: Transformation -> (Ptr CFloat -> IO b) -> IO b
withTransformation t f = with t (\p -> f (castPtr p))

-- | Returns the current transformation matrix.
{#fun unsafe nvgCurrentTransform as currentTransform
        {`Context',allocaTransformation-`Transformation'peekTransformation*} -> `()'#}

-- | Sets the transform to identity matrix.
{#fun unsafe nvgTransformIdentity as transformIdentity
        {allocaTransformation-`Transformation'peekTransformation*} -> `()'#}

-- | Sets the transform to translation matrix matrix.
{#fun unsafe nvgTransformTranslate as transformTranslate
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat',`CFloat'} -> `()'#}

-- | Sets the transform to scale matrix.
{#fun unsafe nvgTransformScale as transformScale
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat',`CFloat'} -> `()'#}

-- | Sets the transform to rotate matrix. Angle is specified in radians.
{#fun unsafe nvgTransformRotate as transformRotate
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

-- | Sets the transform to skew-x matrix. Angle is specified in radians.
{#fun unsafe nvgTransformSkewX as transformSkewX
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

-- | Sets the transform to skew-y matrix. Angle is specified in radians.
{#fun unsafe nvgTransformSkewY as transformSkewY
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

-- | Sets the transform to the result of multiplication of two transforms, of A = A*B.
{#fun unsafe nvgTransformMultiply as transformMultiply
        {withTransformation*`Transformation'peekTransformation*,withTransformation*`Transformation'} -> `()'#}

-- | Sets the transform to the result of multiplication of two transforms, of A = B*A.
{#fun unsafe nvgTransformPremultiply as transformPremultiply
        {withTransformation*`Transformation'peekTransformation*,withTransformation*`Transformation'} -> `()'#}

-- | Sets the destination to inverse of specified transform.
-- Returns 1 if the inverse could be calculated, else 0.
{#fun unsafe nvgTransformInverse as transformInverse
        {allocaTransformation-`Transformation'peekTransformation*,withTransformation*`Transformation'} -> `()'#}

-- | Transform a point by given transform.
{#fun pure unsafe nvgTransformPoint as transformPoint
        {alloca-`CFloat'peek*,alloca-`CFloat'peek*,withTransformation*`Transformation',`CFloat',`CFloat'} -> `()'#}

-- | Converts degrees to radians.
{#fun pure unsafe nvgDegToRad as degToRad
        {`CFloat'} -> `CFloat'#}

-- | Converts radians to degrees.
{#fun pure unsafe nvgRadToDeg as radToDeg
        {`CFloat'} -> `CFloat'#}

safeImage :: CInt -> Maybe Image
safeImage i
  | i < 0 = Nothing
  | otherwise = Just (Image i)

-- | Creates image by loading it from the disk from specified file name.
{#fun unsafe nvgCreateImage as createImage
        {`Context','withCString.unwrapFileName'*`FileName',`CInt'} -> `Maybe Image'safeImage#}

-- | Creates image by loading it from the specified chunk of memory.
{#fun unsafe nvgCreateImageMem as createImageMem
        {`Context',`ImageFlags',useAsCStringLen'*`ByteString'&} -> `Maybe Image'safeImage#}

-- | Creates image from specified image data.
{#fun unsafe nvgCreateImageRGBA as createImageRGBA
        {`Context',`CInt',`CInt',`ImageFlags',useAsPtr*`ByteString'} -> `Maybe Image'safeImage#}

-- | Updates image data specified by image handle.
{#fun unsafe nvgUpdateImage as updateImage
        {`Context',imageHandle`Image',useAsPtr*`ByteString'} -> `()'#}

-- | Returns the dimensions of a created image.
{#fun unsafe nvgImageSize as imageSize
        {`Context',imageHandle`Image',alloca-`CInt'peek*,alloca-`CInt'peek*} -> `()'#}

-- | Deletes created image.
{#fun unsafe nvgDeleteImage as deleteImage
        {`Context',imageHandle`Image'} -> `()'#}

-- | Creates and returns a linear gradient. Parameters (sx,sy)-(ex,ey) specify the start and end coordinates
-- of the linear gradient, icol specifies the start color and ocol the end color.
-- The gradient is transformed by the current transform when it is passed to 'fillPaint' or 'strokePaint'.
{#fun unsafe nvgLinearGradient_ as linearGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

-- | Creates and returns a box gradient. Box gradient is a feathered rounded rectangle, it is useful for rendering
-- drop shadows or highlights for boxes. Parameters (x,y) define the top-left corner of the rectangle,
-- (w,h) define the size of the rectangle, r defines the corner radius, and f feather. Feather defines how blurry
-- the border of the rectangle is. Parameter icol specifies the inner color and ocol the outer color of the gradient.
-- The gradient is transformed by the current transform when it is passed to 'fillPaint' or 'strokePaint'.
{#fun unsafe nvgBoxGradient_ as boxGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

-- | Creates and returns a radial gradient. Parameters (cx,cy) specify the center, inr and outr specify
-- the inner and outer radius of the gradient, icol specifies the start color and ocol the end color.
-- The gradient is transformed by the current transform when it is passed to 'fillPaint' or 'strokePaint'.
{#fun unsafe nvgRadialGradient_ as radialGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

-- | Creates and returns an image patter. Parameters (ox,oy) specify the left-top location of the image pattern,
-- (ex,ey) the size of one image, angle rotation around the top-left corner, image is handle to the image to render.
-- The gradient is transformed by the current transform when it is passed to 'fillPaint' or 'strokePaint'.
{#fun unsafe nvgImagePattern_ as imagePattern
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',imageHandle`Image',`CFloat',alloca-`Paint'peek*} -> `()'#}

-- | Sets the current scissor rectangle.
-- The scissor rectangle is transformed by the current transform.
{#fun unsafe nvgScissor as scissor
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Intersects current scissor rectangle with the specified rectangle.
-- The scissor rectangle is transformed by the current transform.
-- Note: in case the rotation of previous scissor rect differs from
-- the current one, the intersection will be done between the specified
-- rectangle and the previous scissor rectangle transformed in the current
-- transform space. The resulting shape is always rectangle.
{#fun unsafe nvgIntersectScissor as intersectScissor
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Reset and disables scissoring.
{#fun unsafe nvgResetScissor as resetScissor
        {`Context'} -> `()'#}

-- | Clears the current path and sub-paths.
{#fun unsafe nvgBeginPath as beginPath
        {`Context'} -> `()'#}

-- | Starts new sub-path with specified point as first point.
{#fun unsafe nvgMoveTo as moveTo
        {`Context',`CFloat',`CFloat'} -> `()'#}

-- | Adds line segment from the last point in the path to the specified point.
{#fun unsafe nvgLineTo as lineTo
        {`Context',`CFloat',`CFloat'} -> `()'#}

-- | Adds cubic bezier segment from last point in the path via two control points to the specified point.
{#fun unsafe nvgBezierTo as bezierTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Adds quadratic bezier segment from last point in the path via a control point to the specified point
{#fun unsafe nvgQuadTo as quadTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Adds an arc segment at the corner defined by the last path point, and two specified points.
{#fun unsafe nvgArcTo as arcTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Closes current sub-path with a line segment.
{#fun unsafe nvgClosePath as closePath
        {`Context'} -> `()'#}

-- | Sets the current sub-path winding, see NVGwinding and NVGsolidity.
{#fun unsafe nvgPathWinding as pathWinding
        {`Context', `CInt'} -> `()'#}

-- | Creates new circle arc shaped sub-path. The arc center is at cx,cy, the arc radius is r,
-- and the arc is drawn from angle a0 to a1, and swept in direction dir (NVG_CCW, or NVG_CW).
-- Angles are specified in radians.
{#fun unsafe nvgArc as arc
        {`Context',`CFloat',`CFloat', `CFloat', `CFloat', `CFloat', `Winding'} -> `()'#}

-- | Creates new rectangle shaped sub-path.
{#fun unsafe nvgRect as rect
         {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Creates new rounded rectangle shaped sub-path.
{#fun unsafe nvgRoundedRect as roundedRect
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Creates new ellipse shaped sub-path.
{#fun unsafe nvgEllipse as ellipse
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Creates new circle shaped sub-path.
{#fun unsafe nvgCircle as circle
        {`Context',`CFloat',`CFloat',`CFloat'} -> `()'#}

-- | Fills the current path with current fill style.
{#fun unsafe nvgFill as fill
        {`Context'} -> `()'#}

-- | Fills the current path with current stroke style.
{#fun unsafe nvgStroke as stroke
        {`Context'} -> `()'#}

safeFont :: CInt -> Maybe Font
safeFont i
  | i < 0 = Nothing
  | otherwise = Just (Font i)

-- | Creates font by loading it from the disk from specified file name.
-- Returns handle to the font.
{#fun unsafe nvgCreateFont as createFont
        {`Context',withCString*`T.Text','withCString.unwrapFileName'*`FileName'} -> `Maybe Font'safeFont#}

-- | Creates image by loading it from the specified memory chunk.
-- Returns handle to the font.
{#fun unsafe nvgCreateFontMem as createFontMem
        {`Context',withCString*`T.Text',useAsCStringLen'*`ByteString'&,zero-`CInt'} -> `Maybe Font'safeFont#}

-- | Finds a loaded font of specified name, and returns handle to it, or -1 if the font is not found.
{#fun unsafe nvgFindFont as findFont
        {`Context', withCString*`T.Text'} -> `Maybe Font'safeFont#}

-- | Sets the font size of current text style.
{#fun unsafe nvgFontSize as fontSize
        {`Context',`CFloat'} -> `()'#}

-- | Sets the blur of current text style.
{#fun unsafe nvgFontBlur as fontBlur
        {`Context',`CFloat'} -> `()'#}

-- | Sets the letter spacing of current text style.
{#fun unsafe nvgTextLetterSpacing as textLetterSpacing
        {`Context',`CFloat'} -> `()'#}

-- | Sets the proportional line height of current text style. The line height is specified as multiple of font size.
{#fun unsafe nvgTextLineHeight as textLineHeight
        {`Context',`CFloat'} -> `()'#}

-- | Sets the text align of current text style, see NVGalign for options.
{#fun unsafe nvgTextAlign as textAlign
        {`Context',bitMask`S.Set Align'} -> `()'#}

-- | Sets the font face based on specified id of current text style.
{#fun unsafe nvgFontFaceId as fontFaceId
        {`Context',fontHandle`Font'} -> `()'#}

-- | Sets the font face based on specified name of current text styl
{#fun unsafe nvgFontFace as fontFace
        {`Context',withCString*`T.Text'} -> `()'#}

-- | Draws text string at specified location. If end is specified only the sub-string up to the end is drawn.
{#fun unsafe nvgText as text
         {`Context',`CFloat',`CFloat',id`Ptr CChar',id`Ptr CChar'} -> `()'#}

-- | Draws multi-line text string at specified location wrapped at the specified width. If end is specified only the sub-string up to the end is drawn.
-- | White space is stripped at the beginning of the rows, the text is split at word boundaries or when new-line characters are encountered.
-- | Words longer than the max width are slit at nearest character (i.e. no hyphenation).
{#fun unsafe nvgTextBox as textBox
        {`Context',`CFloat',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar'} -> `()'#}

newtype Bounds = Bounds (V4 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Bounds where
  sizeOf _ = sizeOf (0 :: CFloat) * 4
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peekElemOff p' 0
       b <- peekElemOff p' 1
       c <- peekElemOff p' 2
       d <- peekElemOff p' 3
       pure (Bounds (V4 a b c d))
  poke p (Bounds (V4 a b c d)) =
    do let p' = castPtr p :: Ptr CFloat
       pokeElemOff p' 0 a
       pokeElemOff p' 1 b
       pokeElemOff p' 2 c
       pokeElemOff p' 3 d

peekBounds :: Ptr CFloat -> IO Bounds
peekBounds = peek . castPtr

allocaBounds :: (Ptr CFloat -> IO b) -> IO b
allocaBounds f = alloca (\(p :: Ptr Bounds) -> f (castPtr p))

-- | Measures the specified text string. Parameter bounds should be a pointer to float[4],
-- if the bounding box of the text should be returned. The bounds value are [xmin,ymin, xmax,ymax]
-- Returns the horizontal advance of the measured text (i.e. where the next character should drawn).
-- Measured values are returned in local coordinate space.
{#fun unsafe nvgTextBounds as textBounds
        {`Context',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar', allocaBounds-`Bounds'peekBounds*} -> `()'#}

-- | Measures the specified multi-text string. Parameter bounds should be a pointer to float[4],
-- if the bounding box of the text should be returned. The bounds value are [xmin,ymin, xmax,ymax]
-- Measured values are returned in local coordinate space.
{#fun unsafe nvgTextBoxBounds as textBoxBounds
        {`Context',`CFloat',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar',allocaBounds-`Bounds'peekBounds*} -> `()'#}

-- | Calculates the glyph x positions of the specified text. If end is specified only the sub-string will be used.
-- Measured values are returned in local coordinate space.
{#fun unsafe nvgTextGlyphPositions as textGlyphPositions
        {`Context',`CFloat',`CFloat',id`Ptr CChar',id`Ptr CChar',`GlyphPositionPtr', `CInt'} -> `CInt'#}

-- | Returns the vertical metrics based on the current text style.
-- Measured values are returned in local coordinate space.
{#fun unsafe nvgTextMetrics as textMetrics
        {`Context',alloca-`CFloat'peek*,alloca-`CFloat'peek*,alloca-`CFloat'peek*} -> `()'#}

-- | Breaks the specified text into lines. If end is specified only the sub-string will be used.
-- White space is stripped at the beginning of the rows, the text is split at word boundaries or when new-line characters are encountered.
-- Words longer than the max width are slit at nearest character (i.e. no hyphenation).
{#fun unsafe nvgTextBreakLines as textBreakLines
        {`Context',id`Ptr CChar',id`Ptr CChar',`CFloat',`TextRowPtr',`CInt'} -> `CInt'#}

{#enum NVGcreateFlags as CreateFlags
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

bitMask :: Enum a => S.Set a -> CInt
bitMask = S.fold (.|.) 0 . S.map (fromIntegral . fromEnum)

{#fun unsafe nvgCreateGL3 as createGL3
        {bitMask`S.Set CreateFlags'} -> `Context'#}
{#fun unsafe nvgDeleteGL3 as deleteGL3
        {`Context'} -> `()'#}

type GLuint = Word32

{#fun unsafe nvglCreateImageFromHandleGL3 as createImageFromHandleGL3
        {`Context',fromIntegral`GLuint',`CInt',`CInt',`CreateFlags'} -> `Image'Image#}

{#fun unsafe nvglImageHandleGL3 as imageHandleGL3
        {`Context',imageHandle`Image'} -> `GLuint'fromIntegral#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module NanoVG.Internal where

import           Data.Bits
import           Data.ByteString hiding (null)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Word
import           Foreign.C.String (CString)
import           Foreign.C.Types
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import           Linear.Matrix
import           Linear.V2
import           Linear.V3
import           Linear.V4
import           Prelude hiding (null)

-- For now only the GL3 backend is supported
#define NANOVG_GL3
-- We need to include this to define GLuint
#include "GL/glew.h"
#include "nanovg.h"
#include "nanovg_gl.h"
#include "nanovg_wrapper.h"

withCString :: T.Text -> (CString -> IO b) -> IO b
withCString t = useAsCString (T.encodeUtf8 t)

useAsCStringLen' :: ByteString -> ((Ptr CUChar,CInt) -> IO a) -> IO a
useAsCStringLen' bs f = useAsCStringLen bs (\(ptr,len) -> f (castPtr ptr,fromIntegral len))

useAsPtr :: ByteString -> (Ptr CUChar -> IO a) -> IO a
useAsPtr bs f = useAsCStringLen bs (\(ptr,_) -> f (castPtr ptr))

zero :: Num a => (a -> b) -> b
zero f = f 0

null :: (Ptr a -> b) -> b
null f = f nullPtr

newtype FileName = FileName { unwrapFileName :: T.Text }

newtype Image = Image {imageHandle :: CInt} deriving (Show,Read,Eq,Ord)

newtype Font = Font {fontHandle :: CInt} deriving (Show,Read,Eq,Ord)

{#pointer *NVGcontext as Context newtype#}

newtype Transformation = Transformation (M23 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Transformation where
  sizeOf _ = sizeOf (0 :: CFloat) * 6
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peek p'
       b <- peekElemOff p' 1
       c <- peekElemOff p' 2
       d <- peekElemOff p' 3
       e <- peekElemOff p' 4
       f <- peekElemOff p' 5
       pure (Transformation
               (V2 (V3 a c e)
                   (V3 b d f)))
  poke p (Transformation (V2 (V3 a c e) (V3 b d f))) =
    do let p' = castPtr p :: Ptr CFloat
       poke p' a
       pokeElemOff p' 1 b
       pokeElemOff p' 2 c
       pokeElemOff p' 3 d
       pokeElemOff p' 4 e
       pokeElemOff p' 5 f

newtype Extent = Extent (V2 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Extent where
  sizeOf _ = sizeOf (0 :: CFloat) * 2
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peekElemOff p' 0
       b <- peekElemOff p' 1
       pure (Extent (V2 a b))
  poke p (Extent (V2 a b)) =
    do let p' = castPtr p :: Ptr CFloat
       pokeElemOff p' 0 a
       pokeElemOff p' 1 b

-- | rgba
data Color = Color !CFloat !CFloat !CFloat !CFloat deriving (Show,Read,Eq,Ord)

{#pointer *NVGcolor as ColorPtr -> Color#}

instance Storable Color where
  sizeOf _ = sizeOf (0 :: CFloat) * 4
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       r <- peek p'
       g <- peekElemOff p' 1
       b <- peekElemOff p' 2
       a <- peekElemOff p' 3
       pure (Color r g b a)
  poke p (Color r g b a) =
    do let p' = castPtr p :: Ptr CFloat
       poke p' r
       pokeElemOff p' 1 g
       pokeElemOff p' 2 b
       pokeElemOff p' 3 a

data Paint =
  Paint {xform :: Transformation
        ,extent :: Extent
        ,radius :: !CFloat
        ,feather :: !CFloat
        ,innerColor :: !Color
        ,outerColor :: !Color
        ,image :: !Image} deriving (Show,Read,Eq,Ord)

{#pointer *NVGpaint as PaintPtr -> Paint#}

instance Storable Paint where
  sizeOf _ = 76
  alignment _ = 4
  peek p =
    do xform <- peek (castPtr (p `plusPtr` {#offsetof NVGpaint->xform#}))
       extent <- peek (castPtr (p `plusPtr` {#offsetof NVGpaint->extent#}))
       radius <- {#get NVGpaint->radius#} p
       feather <- {#get NVGpaint->feather#} p
       innerColor <- peek (castPtr (p `plusPtr` 40))
       outerColor <- peek (castPtr (p `plusPtr` 56))
       image <- peek (castPtr (p `plusPtr` 72))
       pure (Paint xform extent radius feather innerColor outerColor (Image image))
  poke p (Paint{..}) =
    do poke (castPtr (p `plusPtr` {#offsetof NVGpaint->xform#})) xform
       poke (castPtr (p `plusPtr` {#offsetof NVGpaint->extent#})) extent
       {#set NVGpaint->radius#} p radius
       {#set NVGpaint->feather#} p feather
       poke (castPtr (p `plusPtr` 40)) innerColor
       poke (castPtr (p `plusPtr` 56)) outerColor
       poke (castPtr (p `plusPtr` 72)) (imageHandle image)

{#enum NVGwinding as Winding
         {} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGsolidity as Solidity
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGlineCap as LineCap
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#enum NVGalign as Align
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

data GlyphPosition =
     GlyphPosition { str :: !(Ptr CChar)
                   , glyphX :: !CFloat
                   -- Remove prefix once GHC 8 is released
                   , glyphPosMinX :: !CFloat
                   , glyphPosMaxX :: !CFloat} deriving (Show,Eq,Ord)

{#pointer *NVGglyphPosition as GlyphPositionPtr -> GlyphPosition#}

instance Storable GlyphPosition where
  sizeOf _ = 24
  alignment _ = {#alignof NVGglyphPosition#}
  peek p =
    do str <- {#get NVGglyphPosition->str#} p
       x <- {#get NVGglyphPosition->x#} p
       minx <- {#get NVGglyphPosition->minx#} p
       maxx <- {#get NVGglyphPosition->maxx#} p
       pure (GlyphPosition str x minx maxx)
  poke p (GlyphPosition str x minx maxx) =
    do {#set NVGglyphPosition->str#} p str
       {#set NVGglyphPosition->x#} p x
       {#set NVGglyphPosition->minx#} p minx
       {#set NVGglyphPosition->maxx#} p maxx

data TextRow =
  TextRow {start :: !(Ptr CChar)
          ,end :: !(Ptr CChar)
          ,next :: !(Ptr CChar)
          ,width :: !CFloat
          -- Remove prefix once GHC 8 is released
          ,textRowMinX :: !CFloat
          ,textRowMaxX :: !CFloat} deriving (Show,Eq,Ord)

instance Storable TextRow where
  sizeOf _ = 40
  alignment _ = {#alignof NVGtextRow#}
  peek p =
    do start <- {#get NVGtextRow->start#} p
       end <- {#get NVGtextRow->end#} p
       next <- {#get NVGtextRow->next#} p
       width <- {#get NVGtextRow->width#} p
       minX <- {#get NVGtextRow->minx#} p
       maxX <- {#get NVGtextRow->maxx#} p
       pure (TextRow start end next width minX maxX)
  poke p (TextRow {..}) =
    do {#set NVGtextRow->start#} p start
       {#set NVGtextRow->end#} p end
       {#set NVGtextRow->next#} p next
       {#set NVGtextRow->width#} p width
       {#set NVGtextRow->minx#} p textRowMinX
       {#set NVGtextRow->maxx#} p textRowMaxX

{#pointer *NVGtextRow as TextRowPtr -> TextRow#}

{#enum NVGimageFlags as ImageFlags
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

{#fun unsafe nvgBeginFrame as beginFrame
        {`Context',`CInt',`CInt',`Float'} -> `()'#}

{#fun unsafe nvgCancelFrame as canelFrame
        {`Context'} -> `()'#}

{#fun unsafe nvgEndFrame as endFrame
        {`Context'} -> `()'#}

{#fun pure unsafe nvgRGB_ as rgb
        {id`CUChar',id`CUChar',id`CUChar',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgRGBf_ as rgbf
        {`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgRGBA_ as rgba
        {id`CUChar',id`CUChar',id`CUChar',id`CUChar',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgRGBAf_ as rgbaf
        {`CFloat',`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgLerpRGBA_ as lerpRGBA
        {with*`Color',with*`Color',`CFloat',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgTransRGBA_ as transRGBA
        {with*`Color',id`CUChar',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgTransRGBAf_ as transRGBAf
        {with*`Color',`CFloat',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgHSL_ as hsl
        {`CFloat',`CFloat',`CFloat',alloca-`Color'peek*} -> `()'#}

{#fun pure unsafe nvgHSLA_ as hsla
        {`CFloat',`CFloat',`CFloat',id`CUChar',alloca-`Color'peek*} -> `()'#}

{#fun unsafe nvgSave as save
        {`Context'} -> `()'#}

{#fun unsafe nvgRestore as restore
        {`Context'} -> `()'#}

{#fun unsafe nvgReset as reset
        {`Context'} -> `()'#}

{#fun unsafe nvgStrokeColor_ as strokeColor
        {`Context',with*`Color'} -> `()'#}

{#fun unsafe nvgStrokePaint_ as strokePaint
        {`Context',with*`Paint'} -> `()'#}

{#fun unsafe nvgFillColor_ as fillColor
        {`Context',with*`Color'} -> `()'#}

{#fun unsafe nvgFillPaint_ as fillPaint
        {`Context',with*`Paint'} -> `()'#}

{#fun unsafe nvgMiterLimit as miterLimit
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgStrokeWidth as strokeWidth
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgLineCap as lineCap
        {`Context',`LineCap'} -> `()'#}

{#fun unsafe nvgLineJoin as lineJoin
        {`Context',`LineCap'} -> `()'#}

{#fun unsafe nvgGlobalAlpha as globalAlpha
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgResetTransform as resetTransform
        {`Context'} -> `()'#}

{#fun unsafe nvgTransform as transform
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgTranslate as translate
        {`Context',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgRotate as rotate
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgSkewX as skewX
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgSkewY as skewY
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgScale as scale
        {`Context',`CFloat',`CFloat'} -> `()'#}

peekTransformation :: Ptr CFloat -> IO Transformation
peekTransformation = peek . castPtr

allocaTransformation :: (Ptr CFloat -> IO b) -> IO b
allocaTransformation f = alloca (\(p :: Ptr Transformation) -> f (castPtr p))

withTransformation :: Transformation -> (Ptr CFloat -> IO b) -> IO b
withTransformation t f = with t (\p -> f (castPtr p))

{#fun unsafe nvgCurrentTransform as currentTransform
        {`Context',allocaTransformation-`Transformation'peekTransformation*} -> `()'#}

{#fun unsafe nvgTransformIdentity as transformIdentity
        {allocaTransformation-`Transformation'peekTransformation*} -> `()'#}

{#fun unsafe nvgTransformTranslate as transformTranslate
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgTransformScale as transformScale
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgTransformRotate as transformRotate
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

{#fun unsafe nvgTransformSkewX as transformSkewX
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

{#fun unsafe nvgTransformSkewY as transformSkewY
        {allocaTransformation-`Transformation'peekTransformation*,`CFloat'} -> `()'#}

{#fun unsafe nvgTransformMultiply as transformMultiply
        {allocaTransformation-`Transformation'peekTransformation*,withTransformation*`Transformation'} -> `()'#}

{#fun unsafe nvgTransformInverse as transformInverse
        {allocaTransformation-`Transformation'peekTransformation*,withTransformation*`Transformation'} -> `()'#}

{#fun pure unsafe nvgTransformPoint as transformPoint
        {alloca-`CFloat'peek*,alloca-`CFloat'peek*,withTransformation*`Transformation',`CFloat',`CFloat'} -> `()'#}

{#fun pure unsafe nvgDegToRad as degToRad
        {`CFloat'} -> `CFloat'#}

{#fun pure unsafe nvgRadToDeg as radToDeg
        {`CFloat'} -> `CFloat'#}

safeImage :: CInt -> Maybe Image
safeImage i
  | i < 0 = Nothing
  | otherwise = Just (Image i)

{#fun unsafe nvgCreateImage as createImage
        {`Context','withCString.unwrapFileName'*`FileName',`CInt'} -> `Maybe Image'safeImage#}

{#fun unsafe nvgCreateImageMem as createImageMem
        {`Context',`ImageFlags',useAsCStringLen'*`ByteString'&} -> `Maybe Image'safeImage#}

{#fun unsafe nvgCreateImageRGBA as createImageRGBA
        {`Context',`CInt',`CInt',`ImageFlags',useAsPtr*`ByteString'} -> `Maybe Image'safeImage#}

{#fun unsafe nvgUpdateImage as updateImage
        {`Context',imageHandle`Image',useAsPtr*`ByteString'} -> `()'#}

{#fun unsafe nvgImageSize as imageSize
        {`Context',imageHandle`Image',alloca-`CInt'peek*,alloca-`CInt'peek*} -> `()'#}

{#fun unsafe nvgDeleteImage as deleteImage
        {`Context',imageHandle`Image'} -> `()'#}

{#fun unsafe nvgLinearGradient_ as linearGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

{#fun unsafe nvgBoxGradient_ as boxGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

{#fun unsafe nvgRadialGradient_ as radialGradient
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',with*`Color',with*`Color',alloca-`Paint'peek*} -> `()'#}

{#fun unsafe nvgImagePattern_ as imagePattern
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',imageHandle`Image',`CFloat',alloca-`Paint'peek*} -> `()'#}

{#fun unsafe nvgScissor as scissor
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgIntersectScissor as intersectScissor
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgResetScissor as resetScissor
        {`Context'} -> `()'#}

{#fun unsafe nvgBeginPath as beginPath
        {`Context'} -> `()'#}

{#fun unsafe nvgMoveTo as moveTo
        {`Context',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgLineTo as lineTo
        {`Context',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgBezierTo as bezierTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgQuadTo as quadTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgArcTo as arcTo
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgClosePath as closePath
        {`Context'} -> `()'#}

{#fun unsafe nvgPathWinding as pathWinding
        {`Context', `CInt'} -> `()'#}

{#fun unsafe nvgArc as arc
        {`Context',`CFloat',`CFloat', `CFloat', `CFloat', `CFloat', `Winding'} -> `()'#}

{#fun unsafe nvgRect as rect
         {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgRoundedRect as roundedRect
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgEllipse as ellipse
        {`Context',`CFloat',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgCircle as circle
        {`Context',`CFloat',`CFloat',`CFloat'} -> `()'#}

{#fun unsafe nvgFill as fill
        {`Context'} -> `()'#}

{#fun unsafe nvgStroke as stroke
        {`Context'} -> `()'#}

safeFont :: CInt -> Maybe Font
safeFont i
  | i < 0 = Nothing
  | otherwise = Just (Font i)

{#fun unsafe nvgCreateFont as createFont
        {`Context',withCString*`T.Text','withCString.unwrapFileName'*`FileName'} -> `Maybe Font'safeFont#}

{#fun unsafe nvgCreateFontMem as createFontMem
        {`Context',withCString*`T.Text',useAsCStringLen'*`ByteString'&,zero-`CInt'} -> `Maybe Font'safeFont#}

{#fun unsafe nvgFindFont as findFont
        {`Context', withCString*`T.Text'} -> `Maybe Font'safeFont#}

{#fun unsafe nvgFontSize as fontSize
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgFontBlur as fontBlur
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgTextLetterSpacing as textLetterSpacing
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgTextLineHeight as textLineHeight
        {`Context',`CFloat'} -> `()'#}

{#fun unsafe nvgTextAlign as textAlign
        {`Context',bitMask`S.Set Align'} -> `()'#}

{#fun unsafe nvgFontFaceId as fontFaceId
        {`Context',fontHandle`Font'} -> `()'#}

{#fun unsafe nvgFontFace as fontFace
        {`Context',withCString*`T.Text'} -> `()'#}

{#fun unsafe nvgText as text
         {`Context',`CFloat',`CFloat',id`Ptr CChar',id`Ptr CChar'} -> `()'#}

{#fun unsafe nvgTextBox as textBox
        {`Context',`CFloat',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar'} -> `()'#}

newtype Bounds = Bounds (V4 CFloat) deriving (Show,Read,Eq,Ord)

instance Storable Bounds where
  sizeOf _ = sizeOf (0 :: CFloat) * 4
  alignment _ = alignment (0 :: CFloat)
  peek p =
    do let p' = castPtr p :: Ptr CFloat
       a <- peekElemOff p' 0
       b <- peekElemOff p' 1
       c <- peekElemOff p' 2
       d <- peekElemOff p' 3
       pure (Bounds (V4 a b c d))
  poke p (Bounds (V4 a b c d)) =
    do let p' = castPtr p :: Ptr CFloat
       pokeElemOff p' 0 a
       pokeElemOff p' 1 b
       pokeElemOff p' 2 c
       pokeElemOff p' 3 d

peekBounds :: Ptr CFloat -> IO Bounds
peekBounds = peek . castPtr

allocaBounds :: (Ptr CFloat -> IO b) -> IO b
allocaBounds f = alloca (\(p :: Ptr Bounds) -> f (castPtr p))

withBounds :: Bounds -> (Ptr CFloat -> IO b) -> IO b
withBounds t f = with t (\p -> f (castPtr p))

{#fun unsafe nvgTextBounds as textBounds
        {`Context',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar', allocaBounds-`Bounds'peekBounds*} -> `()'#}

{#fun unsafe nvgTextBoxBounds as textBoxBounds
        {`Context',`CFloat',`CFloat',`CFloat',withCString*`T.Text',null-`Ptr CUChar',allocaBounds-`Bounds'peekBounds*} -> `()'#}

-- TODO: This should probably take a vector
{#fun unsafe nvgTextGlyphPositions as textGlyphPositions
        {`Context',`CFloat',`CFloat',id`Ptr CChar',id`Ptr CChar',`GlyphPositionPtr', `CInt'} -> `CInt'#}

{#fun unsafe nvgTextMetrics as textMetrics
        {`Context',alloca-`CFloat'peek*,alloca-`CFloat'peek*,alloca-`CFloat'peek*} -> `()'#}

-- TODO: This should probably take a vector
{#fun unsafe nvgTextBreakLines as textBreakLines
        {`Context',id`Ptr CChar',id`Ptr CChar',`CFloat',`TextRowPtr',`CInt'} -> `CInt'#}

{#enum NVGcreateFlags as CreateFlags
         {underscoreToCase} with prefix = "NVG_"
         deriving (Show,Read,Eq,Ord)#}

bitMask :: Enum a => S.Set a -> CInt
bitMask = S.fold (.|.) 0 . S.map (fromIntegral . fromEnum)

{#fun unsafe nvgCreateGL3 as createGL3
        {bitMask`S.Set CreateFlags'} -> `Context'#}
{#fun unsafe nvgDeleteGL3 as deleteGL3
        {`Context'} -> `()'#}

type GLuint = Word32

{#fun unsafe nvglCreateImageFromHandleGL3 as createImageFromHandleGL3
        {`Context',fromIntegral`GLuint',`CInt',`CInt',`CreateFlags'} -> `Image'Image#}

{#fun unsafe nvglImageHandleGL3 as imageHandleGL3
        {`Context',imageHandle`Image'} -> `GLuint'fromIntegral#}


Fix a conflict in DrawWindow.

Fix a conflict in DrawWindow.

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) DrawWindow
--
--  Author : Axel Simon
--
--  Created: 5 November 2002
--
--  Copyright (C) 2002-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 'DrawWindow' is a rectangular region on the screen.
--
module Graphics.UI.Gtk.Gdk.DrawWindow (
-- A 'DrawWindow' is used to implement high-level objects such as 'Widget' and
-- 'Window' on the Gtk+ level.
--
-- Most widgets draws its content into a 'DrawWindow', in particular
-- 'DrawingArea' is nothing but a widget that contains a 'DrawWindow'.
-- This object derives from 'Drawable' which defines the basic drawing
-- primitives.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Drawable'
-- |         +----DrawWindow
-- @
--

-- * Types
  DrawWindow,
  DrawWindowClass,
  castToDrawWindow,
  WindowState(..),
  NativeWindowId,
-- * Methods
  drawWindowGetState,
  drawWindowClear,
  drawWindowClearArea,
  drawWindowClearAreaExpose,
  drawWindowRaise,
  drawWindowLower,
  drawWindowBeginPaintRect,
  drawWindowBeginPaintRegion,
  drawWindowEndPaint,
  drawWindowInvalidateRect,
  drawWindowInvalidateRegion,
  drawWindowGetUpdateArea,
  drawWindowFreezeUpdates,
  drawWindowThawUpdates,
  drawWindowProcessUpdates,
#if GTK_CHECK_VERSION(2,4,0)
  drawWindowSetAcceptFocus,
#endif
  drawWindowShapeCombineMask,
  drawWindowShapeCombineRegion,
  drawWindowSetChildShapes,
  drawWindowMergeChildShapes,
  drawWindowGetPointer,
  drawWindowGetPointerPos,
  drawWindowGetOrigin,
  drawWindowForeignNew
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.Flags                (toFlags)
import System.Glib.GObject      (makeNewGObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Gdk.Enums#}
{#import Graphics.UI.Gtk.Gdk.Region#}
import Graphics.UI.Gtk.Gdk.EventM	(Modifier, eventRegion)
import Graphics.UI.Gtk.General.Structs
import Graphics.UI.Gtk.Abstract.Widget	(widgetSetDoubleBuffered)

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

-- | Gets the bitwise OR of the currently active drawWindow state flags, from
-- the 'WindowState' enumeration.
--
drawWindowGetState :: DrawWindowClass self => self
 -> IO [WindowState] -- ^ returns @DrawWindow@ flags
drawWindowGetState self =
  liftM (toFlags . fromIntegral) $
  {# call gdk_window_get_state #}
     (toDrawWindow self)

-- | Scroll the contents of @DrawWindow@.
--
-- * Scroll both, pixels and children, by the given amount.
--   @DrawWindow@ itself does not move. Portions of the window that the
-- scroll operation brings inm from offscreen areas are invalidated. The
-- invalidated region may be bigger than what would strictly be necessary. (For
-- X11, a minimum area will be invalidated if the window has no subwindows, or
-- if the edges of the window's parent do not extend beyond the edges of the
-- drawWindow. In other cases, a multi-step process is used to scroll the window
-- which may produce temporary visual artifacts and unnecessary invalidations.)
--
drawWindowScroll :: DrawWindowClass self => self
 -> Int   -- ^ @dx@ - Amount to scroll in the X direction
 -> Int   -- ^ @dy@ - Amount to scroll in the Y direction
 -> IO ()
drawWindowScroll self dx dy =
  {# call gdk_window_scroll #}
     (toDrawWindow self)
     (fromIntegral dx)
     (fromIntegral dy)

-- | Clears an entire @DrawWindow@ to the background color or background pixmap.
--
drawWindowClear :: DrawWindowClass self => self -> IO ()
drawWindowClear self =
  {# call gdk_window_clear #}
     (toDrawWindow self)

-- | Clears an area of @DrawWindow@ to the background color or background pixmap.
--
drawWindowClearArea :: DrawWindowClass self => self
 -> Int   -- ^ @x@ - x coordinate of rectangle to clear
 -> Int   -- ^ @y@ - y coordinate of rectangle to clear
 -> Int   -- ^ @width@ - width of rectangle to clear
 -> Int   -- ^ @height@ - height of rectangle to clear
 -> IO ()
drawWindowClearArea self x y width height =
  {# call gdk_window_clear_area #}
     (toDrawWindow self)
     (fromIntegral x)
     (fromIntegral y)
     (fromIntegral width)
     (fromIntegral height)

-- | Like 'drawWindowClearArea', but also generates an expose event for the
-- cleared area.
--
drawWindowClearAreaExpose :: DrawWindowClass self => self
 -> Int   -- ^ @x@ - x coordinate of rectangle to clear
 -> Int   -- ^ @y@ - y coordinate of rectangle to clear
 -> Int   -- ^ @width@ - width of rectangle to clear
 -> Int   -- ^ @height@ - height of rectangle to clear
 -> IO ()
drawWindowClearAreaExpose self x y width height =
  {# call gdk_window_clear_area_e #}
     (toDrawWindow self)
     (fromIntegral x)
     (fromIntegral y)
     (fromIntegral width)
     (fromIntegral height)

-- | Raises @DrawWindow@ to the top of the Z-order (stacking order), so that other
-- drawWindows with the same parent drawWindow appear below @DrawWindow@. This is true
-- whether or not the drawWindows are visible.
--
-- If @DrawWindow@ is a toplevel, the window manager may choose to deny the
-- request to move the drawWindow in the Z-order, 'drawWindowRaise' only requests the
-- restack, does not guarantee it.
--
drawWindowRaise :: DrawWindowClass self => self -> IO ()
drawWindowRaise self =
  {# call gdk_window_raise #}
     (toDrawWindow self)

-- | Lowers @DrawWindow@ to the bottom of the Z-order (stacking order), so that
-- other windows with the same parent window appear above @DrawWindow@. This is
-- true whether or not the other windows are visible.
--
-- If @DrawWindow@ is a toplevel, the window manager may choose to deny the
-- request to move the drawWindow in the Z-order, 'drawWindowLower' only
-- requests the restack, does not guarantee it.
--
-- Note that a widget is raised automatically when it is mapped, thus you
-- need to call 'drawWindowLower' after
        -- 'Graphics.UI.Gtk.Abstract.Widget.widgetShow' if the window should
-- not appear above other windows.
--
drawWindowLower :: DrawWindowClass self => self -> IO ()
drawWindowLower self =
  {# call gdk_window_lower #}
     (toDrawWindow self)

-- | Registers a drawWindow as a potential drop destination.
--
drawWindowRegisterDnd :: DrawWindowClass self => self -> IO ()
drawWindowRegisterDnd self =
  {# call gdk_window_register_dnd #}
     (toDrawWindow self)

-- | A convenience wrapper around 'drawWindowBeginPaintRegion' which creates a
-- rectangular region for you.
--
-- * See 'drawWindowBeginPaintRegion' for details.
--
drawWindowBeginPaintRect :: DrawWindowClass self => self
 -> Rectangle -- ^ @rectangle@ - rectangle you intend to draw to
 -> IO ()
drawWindowBeginPaintRect self rectangle = with rectangle $ \rectPtr ->
  {#call gdk_window_begin_paint_rect#} (toDrawWindow self) (castPtr rectPtr)

-- | Indicate that you are beginning the process of redrawing @region@.
--
-- * A
-- backing store (offscreen buffer) large enough to contain @region@ will be
-- created. The backing store will be initialized with the background color or
-- background pixmap for @DrawWindow@. Then, all drawing operations performed on
-- @DrawWindow@ will be diverted to the backing store. When you call
-- 'drawWindowEndPaint', the backing store will be copied to @DrawWindow@, making it
-- visible onscreen. Only the part of @DrawWindow@ contained in @region@ will be
-- modified; that is, drawing operations are clipped to @region@.
--
-- The net result of all this is to remove flicker, because the user sees
-- the finished product appear all at once when you call 'drawWindowEndPaint'. If
-- you draw to @DrawWindow@ directly without calling 'drawWindowBeginPaintRegion', the
-- user may see flicker as individual drawing operations are performed in
-- sequence. The clipping and background-initializing features of
-- 'drawWindowBeginPaintRegion' are conveniences for the programmer, so you can
-- avoid doing that work yourself.
--
-- When using GTK+, the widget system automatically places calls to
-- 'drawWindowBeginPaintRegion' and 'drawWindowEndPaint' around emissions of the
-- @expose_event@ signal. That is, if you\'re writing an expose event handler,
-- you can assume that the exposed area in 'eventRegion' has already been
-- cleared to the window background, is already set as the clip region, and
-- already has a backing store. Therefore in most cases, application code need
-- not call 'drawWindowBeginPaintRegion'. (You can disable the automatic calls
-- around expose events on a widget-by-widget basis by calling
-- 'widgetSetDoubleBuffered'.)
--
-- If you call this function multiple times before calling the matching
-- 'drawWindowEndPaint', the backing stores are pushed onto a stack.
-- 'drawWindowEndPaint' copies the topmost backing store onscreen, subtracts the
-- topmost region from all other regions in the stack, and pops the stack. All
-- drawing operations affect only the topmost backing store in the stack. One
-- matching call to 'drawWindowEndPaint' is required for each call to
-- 'drawWindowBeginPaintRegion'.
--
drawWindowBeginPaintRegion :: DrawWindowClass self => self
 -> Region -- ^ @region@ - region you intend to draw to
 -> IO ()
drawWindowBeginPaintRegion self region =
  {# call gdk_window_begin_paint_region #}
     (toDrawWindow self)
     region

-- | Signal that drawing has finished.
--
-- * Indicates that the backing store created by the most recent call to
-- 'drawWindowBeginPaintRegion' should be copied onscreen and deleted, leaving the
-- next-most-recent backing store or no backing store at all as the active
-- paint region. See 'drawWindowBeginPaintRegion' for full details. It is an error
-- to call this function without a matching 'drawWindowBeginPaintRegion' first.
--
drawWindowEndPaint :: DrawWindowClass self => self -> IO ()
drawWindowEndPaint self =
  {# call gdk_window_end_paint #}
     (toDrawWindow self)

-- | A convenience wrapper around 'drawWindowInvalidateRegion' which invalidates a
-- rectangular region. See 'drawWindowInvalidateRegion' for details.
--
drawWindowInvalidateRect :: DrawWindowClass self => self
 -> Rectangle -- ^ @rect@ - rectangle to invalidate
 -> Bool              -- ^ @invalidateChildren@ - whether to also invalidate
                      -- child drawWindows
 -> IO ()
drawWindowInvalidateRect self rect invalidateChildren =
  with rect $ \rectPtr ->
  {# call gdk_window_invalidate_rect #}
     (toDrawWindow self)
     (castPtr rectPtr)
     (fromBool invalidateChildren)

-- | Adds @region@ to the update area for @DrawWindow@. The update area is the
-- region that needs to be redrawn, or \"dirty region.\". During the
-- next idle period of the main look, an expose even for this region
-- will be created. An application would normally redraw
-- the contents of @DrawWindow@ in response to those expose events.
--
-- The @invalidateChildren@ parameter controls whether the region of each
-- child drawWindow that intersects @region@ will also be invalidated. If @False@,
-- then the update area for child drawWindows will remain unaffected.
--
drawWindowInvalidateRegion :: DrawWindowClass self => self
 -> Region -- ^ @region@ - a "Region"
 -> Bool           -- ^ @invalidateChildren@ - @True@ to also invalidate child
                   -- drawWindows
 -> IO ()
drawWindowInvalidateRegion self region invalidateChildren =
  {# call gdk_window_invalidate_region #}
     (toDrawWindow self)
     region
     (fromBool invalidateChildren)

-- | Ask for the dirty region of this window.
--
-- * Transfers ownership of the update area from @DrawWindow@ to the caller of the
-- function. That is, after calling this function, @DrawWindow@ will no longer have
-- an invalid\/dirty region; the update area is removed from @DrawWindow@ and
-- handed to you. If this window has no update area, 'drawWindowGetUpdateArea' returns 'Nothing'.
--
drawWindowGetUpdateArea :: DrawWindowClass self => self
 -> IO (Maybe Region) -- ^ returns the update area for @DrawWindow@
drawWindowGetUpdateArea self = do
  reg <- {# call gdk_window_get_update_area #} (toDrawWindow self)
  if reg==nullPtr then return Nothing else liftM Just (makeNewRegion reg)

-- | Temporarily freezes a drawWindow such that it won\'t receive expose events.
--  * The drawWindow will begin receiving expose events again when
--  'drawWindowThawUpdates'
-- is called. If 'drawWindowFreezeUpdates' has been called more than once,
-- 'drawWindowThawUpdates' must be called an equal number of times to begin
-- processing exposes.
--
drawWindowFreezeUpdates :: DrawWindowClass self => self -> IO ()
drawWindowFreezeUpdates self =
  {# call gdk_window_freeze_updates #}
     (toDrawWindow self)

-- | Thaws a drawWindow frozen with 'drawWindowFreezeUpdates'.
--
drawWindowThawUpdates :: DrawWindowClass self => self -> IO ()
drawWindowThawUpdates self =
  {# call gdk_window_thaw_updates #}
     (toDrawWindow self)

-- | Sends one or more expose events to @DrawWindow@.
--
-- * The areas in each expose
-- event will cover the entire update area for the window (see
-- 'drawWindowInvalidateRegion' for details). Normally Gtk calls
-- 'drawWindowProcessUpdates' on your behalf, so there's no need to call this
-- function unless you want to force expose events to be delivered immediately
-- and synchronously (vs. the usual case, where Gtk delivers them in an idle
-- handler). Occasionally this is useful to produce nicer scrolling behavior,
-- for example.
--
drawWindowProcessUpdates :: DrawWindowClass self => self
 -> Bool  -- ^ @updateChildren@ - whether to also process updates for child
          -- drawWindows
 -> IO ()
drawWindowProcessUpdates self updateChildren =
  {# call gdk_window_process_updates #}
     (toDrawWindow self)
     (fromBool updateChildren)

#if GTK_CHECK_VERSION(2,4,0)
-- | Setting @acceptFocus@ to @False@ hints the desktop environment that the
-- window doesn\'t want to receive input focus.
--
-- On X, it is the responsibility of the drawWindow manager to interpret this
-- hint. ICCCM-compliant drawWindow manager usually respect it.
--
-- * Available since Gdk version 2.4
--
drawWindowSetAcceptFocus :: DrawWindowClass self => self
 -> Bool  -- ^ @acceptFocus@ - @True@ if the drawWindow should receive input focus
 -> IO ()
drawWindowSetAcceptFocus self acceptFocus =
  {# call gdk_window_set_accept_focus #}
     (toDrawWindow self)
     (fromBool acceptFocus)
#endif

-- | Applies a shape mask to window. Pixels in window corresponding to set
--   bits in the mask will be visible; pixels in window corresponding to
--   unset bits in the mask will be transparent. This gives a non-rectangular
--   window.
--
-- * If @mask@ is @Nothing@, the shape mask will be unset, and the x\/y parameters
--   are not used. The @mask@ must be a bitmap, that is, a 'Pixmap' of depth
--   one.
--
-- * On the X11 platform, this uses an X server extension which is widely
--   available on most common platforms, but not available on very old
--   X servers, and occasionally the implementation will be buggy.
--   On servers without the shape extension, this function will do nothing.
--   On the Win32 platform the functionality is always present.
--
-- * This function works on both toplevel and child windows.
--
drawWindowShapeCombineMask :: DrawWindowClass self => self
 -> Maybe Pixmap -- ^ @mask@ - region of drawWindow to be non-transparent
 -> Int            -- ^ @offsetX@ - X position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> Int            -- ^ @offsetY@ - Y position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> IO ()
drawWindowShapeCombineMask self (Just (Pixmap mask)) offsetX offsetY =
  withForeignPtr mask $ \maskPtr ->
  {# call gdk_window_shape_combine_mask #}
     (toDrawWindow self)
     (castPtr maskPtr)
     (fromIntegral offsetX)
     (fromIntegral offsetY)
drawWindowShapeCombineMask self Nothing offsetX offsetY =
  {# call gdk_window_shape_combine_mask #}
     (toDrawWindow self)
     nullPtr
     (fromIntegral offsetX)
     (fromIntegral offsetY)

-- | Makes pixels in @DrawWindow@ outside @shapeRegion@ transparent.
--
-- * Makes pixels in @DrawWindow@ outside @shapeRegion@ transparent, so that
-- the window may be nonrectangular.
--
-- If @shapeRegion@ is 'Nothing', the shape will be unset, so the whole
-- 'DrawWindow' will be opaque again. The parameters @offsetX@ and @offsetY@
-- are ignored if @shapeRegion@ is 'Nothing'.
--
-- On the X11 platform, this uses an X server extension which is widely
-- available on most common platforms, but not available on very old X servers,
-- and occasionally the implementation will be buggy. On servers without the
-- shape extension, this function will do nothing.
--
-- This function works on both toplevel and child drawWindows.
--
drawWindowShapeCombineRegion :: DrawWindowClass self => self
 -> Maybe Region -- ^ @shapeRegion@ - region of drawWindow to be non-transparent
 -> Int            -- ^ @offsetX@ - X position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> Int            -- ^ @offsetY@ - Y position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> IO ()
drawWindowShapeCombineRegion self (Just reg) offsetX offsetY =
  {# call gdk_window_shape_combine_region #}
     (toDrawWindow self)
     reg
     (fromIntegral offsetX)
     (fromIntegral offsetY)
drawWindowShapeCombineRegion self Nothing offsetX offsetY =
  {# call gdk_window_shape_combine_region #}
     (toDrawWindow self)
     (Region nullForeignPtr)
     (fromIntegral offsetX)
     (fromIntegral offsetY)

-- | Sets the shape mask of @DrawWindow@ to the union of shape masks for all
-- children of @DrawWindow@, ignoring the shape mask of @DrawWindow@ itself. Contrast
-- with 'drawWindowMergeChildShapes' which includes the shape mask of @DrawWindow@ in
-- the masks to be merged.
--
drawWindowSetChildShapes :: DrawWindowClass self => self -> IO ()
drawWindowSetChildShapes self =
  {# call gdk_window_set_child_shapes #}
     (toDrawWindow self)

-- | Merges the shape masks for any child drawWindows into the shape mask for
-- @DrawWindow@. i.e. the union of all masks for @DrawWindow@ and its children will
-- become the new mask for @DrawWindow@. See 'drawWindowShapeCombineMask'.
--
-- This function is distinct from 'drawWindowSetChildShapes' because it includes
-- @DrawWindow@'s shape mask in the set of shapes to be merged.
--
drawWindowMergeChildShapes :: DrawWindowClass self => self -> IO ()
drawWindowMergeChildShapes self =
  {# call gdk_window_merge_child_shapes #}
     (toDrawWindow self)

-- Superseded by 'drawWindowGetPointerPos', won't be removed.
-- Obtains the current pointer position and modifier state.
--
-- * The position is
-- given in coordinates relative to the given window.
--
-- * The return value is @Just (same, x, y, mod)@ where @same@ is @True@
--   if the passed in window is the window over which the mouse currently
--   resides.
--
-- * The return value is @Nothing@ if the mouse cursor is over a different
--   application.
--
drawWindowGetPointer :: DrawWindowClass self => self
 -> IO (Maybe (Bool, Int, Int, [Modifier]))
drawWindowGetPointer self =
  alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \mPtr -> do
  winPtr <- {# call gdk_window_get_pointer #} (toDrawWindow self)
     xPtr yPtr mPtr
  if winPtr==nullPtr then return Nothing else do
  same <- withForeignPtr (unDrawWindow (toDrawWindow self)) $ \dPtr ->
          return (winPtr==dPtr)
  x <- peek xPtr
  y <- peek yPtr
  m <- peek mPtr
  return (Just (same, fromIntegral x, fromIntegral y,
                toFlags (fromIntegral m)))

-- | Obtains the current pointer position and modifier state.
--
-- * The position is
-- given in coordinates relative to the given window.
--
-- * The return value is @(Just win, x, y, mod)@ where @win@ is the
--   window over which the mouse currently resides and @mod@ denotes
--   the keyboard modifiers currently being depressed.
--
-- * The return value is @Nothing@ for the window if the mouse cursor is
--   not over a known window.
--
drawWindowGetPointerPos :: DrawWindowClass self => self
 -> IO (Maybe DrawWindow, Int, Int, [Modifier])
drawWindowGetPointerPos self =
  alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \mPtr -> do
  winPtr <- {# call gdk_window_get_pointer #} (toDrawWindow self)
     xPtr yPtr mPtr
  x <- peek xPtr
  y <- peek yPtr
  m <- peek mPtr
  mWin <- if winPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkDrawWindow (return winPtr)
  return (mWin, fromIntegral x, fromIntegral y, toFlags (fromIntegral m))

-- | Obtains the position of a window in screen coordinates.
--
-- You can use this to help convert a position between screen coordinates and
-- local 'DrawWindow' relative coordinates.
--
drawWindowGetOrigin :: DrawWindow
 -> IO (Int, Int) -- ^ @(x, y)@
drawWindowGetOrigin self =
  alloca $ \xPtr ->
  alloca $ \yPtr -> do
  {# call gdk_window_get_origin #}
    (toDrawWindow self)
    xPtr
    yPtr
  x <- peek xPtr
  y <- peek yPtr
  return (fromIntegral x, fromIntegral y)

-- | Get the handle to an exising window of the windowing system. The
-- passed-in handle is a reference to a native window, that is, an Xlib XID
-- for X windows and a HWND for Win32.
drawWindowForeignNew :: NativeWindowId -> IO (Maybe DrawWindow)
drawWindowForeignNew anid = maybeNull (makeNewGObject mkDrawWindow) $
  liftM castPtr $ {#call gdk_window_foreign_new#} (fromNativeWindowId anid)

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) DrawWindow
--
--  Author : Axel Simon
--
--  Created: 5 November 2002
--
--  Copyright (C) 2002-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 'DrawWindow' is a rectangular region on the screen.
--
module Graphics.UI.Gtk.Gdk.DrawWindow (
-- A 'DrawWindow' is used to implement high-level objects such as 'Widget' and
-- 'Window' on the Gtk+ level.
--
-- Most widgets draws its content into a 'DrawWindow', in particular
-- 'DrawingArea' is nothing but a widget that contains a 'DrawWindow'.
-- This object derives from 'Drawable' which defines the basic drawing
-- primitives.

-- * Class Hierarchy
-- |
-- @
-- |  'GObject'
-- |   +----'Drawable'
-- |         +----DrawWindow
-- @
--

-- * Types
  DrawWindow,
  DrawWindowClass,
  castToDrawWindow,
  WindowState(..),
  NativeWindowId,
-- * Methods
  drawWindowGetState,
  drawWindowClear,
  drawWindowClearArea,
  drawWindowClearAreaExpose,
  drawWindowRaise,
  drawWindowLower,
  drawWindowBeginPaintRect,
  drawWindowBeginPaintRegion,
  drawWindowEndPaint,
  drawWindowInvalidateRect,
  drawWindowInvalidateRegion,
  drawWindowGetUpdateArea,
  drawWindowFreezeUpdates,
  drawWindowThawUpdates,
  drawWindowProcessUpdates,
#if GTK_CHECK_VERSION(2,4,0)
  drawWindowSetAcceptFocus,
#endif
  drawWindowShapeCombineMask,
  drawWindowShapeCombineRegion,
  drawWindowSetChildShapes,
  drawWindowMergeChildShapes,
  drawWindowGetPointer,
  drawWindowGetPointerPos,
  drawWindowGetOrigin,
  drawWindowForeignNew
  ) where

import Control.Monad    (liftM)

import System.Glib.FFI
import System.Glib.Flags                (toFlags)
import System.Glib.GObject      (makeNewGObject)
{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.Gdk.Enums#}
{#import Graphics.UI.Gtk.Gdk.Region#}
import Graphics.UI.Gtk.Gdk.Events	(Modifier)
import Graphics.UI.Gtk.General.Structs
import Graphics.UI.Gtk.Abstract.Widget	(widgetSetDoubleBuffered)

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

-- | Gets the bitwise OR of the currently active drawWindow state flags, from
-- the 'WindowState' enumeration.
--
drawWindowGetState :: DrawWindowClass self => self
 -> IO [WindowState] -- ^ returns @DrawWindow@ flags
drawWindowGetState self =
  liftM (toFlags . fromIntegral) $
  {# call gdk_window_get_state #}
     (toDrawWindow self)

-- | Scroll the contents of @DrawWindow@.
--
-- * Scroll both, pixels and children, by the given amount.
--   @DrawWindow@ itself does not move. Portions of the window that the
-- scroll operation brings inm from offscreen areas are invalidated. The
-- invalidated region may be bigger than what would strictly be necessary. (For
-- X11, a minimum area will be invalidated if the window has no subwindows, or
-- if the edges of the window's parent do not extend beyond the edges of the
-- drawWindow. In other cases, a multi-step process is used to scroll the window
-- which may produce temporary visual artifacts and unnecessary invalidations.)
--
drawWindowScroll :: DrawWindowClass self => self
 -> Int   -- ^ @dx@ - Amount to scroll in the X direction
 -> Int   -- ^ @dy@ - Amount to scroll in the Y direction
 -> IO ()
drawWindowScroll self dx dy =
  {# call gdk_window_scroll #}
     (toDrawWindow self)
     (fromIntegral dx)
     (fromIntegral dy)

-- | Clears an entire @DrawWindow@ to the background color or background pixmap.
--
drawWindowClear :: DrawWindowClass self => self -> IO ()
drawWindowClear self =
  {# call gdk_window_clear #}
     (toDrawWindow self)

-- | Clears an area of @DrawWindow@ to the background color or background pixmap.
--
drawWindowClearArea :: DrawWindowClass self => self
 -> Int   -- ^ @x@ - x coordinate of rectangle to clear
 -> Int   -- ^ @y@ - y coordinate of rectangle to clear
 -> Int   -- ^ @width@ - width of rectangle to clear
 -> Int   -- ^ @height@ - height of rectangle to clear
 -> IO ()
drawWindowClearArea self x y width height =
  {# call gdk_window_clear_area #}
     (toDrawWindow self)
     (fromIntegral x)
     (fromIntegral y)
     (fromIntegral width)
     (fromIntegral height)

-- | Like 'drawWindowClearArea', but also generates an expose event for the
-- cleared area.
--
drawWindowClearAreaExpose :: DrawWindowClass self => self
 -> Int   -- ^ @x@ - x coordinate of rectangle to clear
 -> Int   -- ^ @y@ - y coordinate of rectangle to clear
 -> Int   -- ^ @width@ - width of rectangle to clear
 -> Int   -- ^ @height@ - height of rectangle to clear
 -> IO ()
drawWindowClearAreaExpose self x y width height =
  {# call gdk_window_clear_area_e #}
     (toDrawWindow self)
     (fromIntegral x)
     (fromIntegral y)
     (fromIntegral width)
     (fromIntegral height)

-- | Raises @DrawWindow@ to the top of the Z-order (stacking order), so that other
-- drawWindows with the same parent drawWindow appear below @DrawWindow@. This is true
-- whether or not the drawWindows are visible.
--
-- If @DrawWindow@ is a toplevel, the window manager may choose to deny the
-- request to move the drawWindow in the Z-order, 'drawWindowRaise' only requests the
-- restack, does not guarantee it.
--
drawWindowRaise :: DrawWindowClass self => self -> IO ()
drawWindowRaise self =
  {# call gdk_window_raise #}
     (toDrawWindow self)

-- | Lowers @DrawWindow@ to the bottom of the Z-order (stacking order), so that
-- other windows with the same parent window appear above @DrawWindow@. This is
-- true whether or not the other windows are visible.
--
-- If @DrawWindow@ is a toplevel, the window manager may choose to deny the
-- request to move the drawWindow in the Z-order, 'drawWindowLower' only
-- requests the restack, does not guarantee it.
--
-- Note that a widget is raised automatically when it is mapped, thus you
-- need to call 'drawWindowLower' after
        -- 'Graphics.UI.Gtk.Abstract.Widget.widgetShow' if the window should
-- not appear above other windows.
--
drawWindowLower :: DrawWindowClass self => self -> IO ()
drawWindowLower self =
  {# call gdk_window_lower #}
     (toDrawWindow self)

-- | Registers a drawWindow as a potential drop destination.
--
drawWindowRegisterDnd :: DrawWindowClass self => self -> IO ()
drawWindowRegisterDnd self =
  {# call gdk_window_register_dnd #}
     (toDrawWindow self)

-- | A convenience wrapper around 'drawWindowBeginPaintRegion' which creates a
-- rectangular region for you.
--
-- * See 'drawWindowBeginPaintRegion' for details.
--
drawWindowBeginPaintRect :: DrawWindowClass self => self
 -> Rectangle -- ^ @rectangle@ - rectangle you intend to draw to
 -> IO ()
drawWindowBeginPaintRect self rectangle = with rectangle $ \rectPtr ->
  {#call gdk_window_begin_paint_rect#} (toDrawWindow self) (castPtr rectPtr)

-- | Indicate that you are beginning the process of redrawing @region@.
--
-- * A
-- backing store (offscreen buffer) large enough to contain @region@ will be
-- created. The backing store will be initialized with the background color or
-- background pixmap for @DrawWindow@. Then, all drawing operations performed on
-- @DrawWindow@ will be diverted to the backing store. When you call
-- 'drawWindowEndPaint', the backing store will be copied to @DrawWindow@, making it
-- visible onscreen. Only the part of @DrawWindow@ contained in @region@ will be
-- modified; that is, drawing operations are clipped to @region@.
--
-- The net result of all this is to remove flicker, because the user sees
-- the finished product appear all at once when you call 'drawWindowEndPaint'. If
-- you draw to @DrawWindow@ directly without calling 'drawWindowBeginPaintRegion', the
-- user may see flicker as individual drawing operations are performed in
-- sequence. The clipping and background-initializing features of
-- 'drawWindowBeginPaintRegion' are conveniences for the programmer, so you can
-- avoid doing that work yourself.
--
-- When using GTK+, the widget system automatically places calls to
-- 'drawWindowBeginPaintRegion' and 'drawWindowEndPaint' around emissions of the
-- @expose_event@ signal. That is, if you\'re writing an expose event handler,
-- you can assume that the exposed area in 'eventRegion' has already been
-- cleared to the window background, is already set as the clip region, and
-- already has a backing store. Therefore in most cases, application code need
-- not call 'drawWindowBeginPaintRegion'. (You can disable the automatic calls
-- around expose events on a widget-by-widget basis by calling
-- 'widgetSetDoubleBuffered'.)
--
-- If you call this function multiple times before calling the matching
-- 'drawWindowEndPaint', the backing stores are pushed onto a stack.
-- 'drawWindowEndPaint' copies the topmost backing store onscreen, subtracts the
-- topmost region from all other regions in the stack, and pops the stack. All
-- drawing operations affect only the topmost backing store in the stack. One
-- matching call to 'drawWindowEndPaint' is required for each call to
-- 'drawWindowBeginPaintRegion'.
--
drawWindowBeginPaintRegion :: DrawWindowClass self => self
 -> Region -- ^ @region@ - region you intend to draw to
 -> IO ()
drawWindowBeginPaintRegion self region =
  {# call gdk_window_begin_paint_region #}
     (toDrawWindow self)
     region

-- | Signal that drawing has finished.
--
-- * Indicates that the backing store created by the most recent call to
-- 'drawWindowBeginPaintRegion' should be copied onscreen and deleted, leaving the
-- next-most-recent backing store or no backing store at all as the active
-- paint region. See 'drawWindowBeginPaintRegion' for full details. It is an error
-- to call this function without a matching 'drawWindowBeginPaintRegion' first.
--
drawWindowEndPaint :: DrawWindowClass self => self -> IO ()
drawWindowEndPaint self =
  {# call gdk_window_end_paint #}
     (toDrawWindow self)

-- | A convenience wrapper around 'drawWindowInvalidateRegion' which invalidates a
-- rectangular region. See 'drawWindowInvalidateRegion' for details.
--
drawWindowInvalidateRect :: DrawWindowClass self => self
 -> Rectangle -- ^ @rect@ - rectangle to invalidate
 -> Bool              -- ^ @invalidateChildren@ - whether to also invalidate
                      -- child drawWindows
 -> IO ()
drawWindowInvalidateRect self rect invalidateChildren =
  with rect $ \rectPtr ->
  {# call gdk_window_invalidate_rect #}
     (toDrawWindow self)
     (castPtr rectPtr)
     (fromBool invalidateChildren)

-- | Adds @region@ to the update area for @DrawWindow@. The update area is the
-- region that needs to be redrawn, or \"dirty region.\". During the
-- next idle period of the main look, an expose even for this region
-- will be created. An application would normally redraw
-- the contents of @DrawWindow@ in response to those expose events.
--
-- The @invalidateChildren@ parameter controls whether the region of each
-- child drawWindow that intersects @region@ will also be invalidated. If @False@,
-- then the update area for child drawWindows will remain unaffected.
--
drawWindowInvalidateRegion :: DrawWindowClass self => self
 -> Region -- ^ @region@ - a "Region"
 -> Bool           -- ^ @invalidateChildren@ - @True@ to also invalidate child
                   -- drawWindows
 -> IO ()
drawWindowInvalidateRegion self region invalidateChildren =
  {# call gdk_window_invalidate_region #}
     (toDrawWindow self)
     region
     (fromBool invalidateChildren)

-- | Ask for the dirty region of this window.
--
-- * Transfers ownership of the update area from @DrawWindow@ to the caller of the
-- function. That is, after calling this function, @DrawWindow@ will no longer have
-- an invalid\/dirty region; the update area is removed from @DrawWindow@ and
-- handed to you. If this window has no update area, 'drawWindowGetUpdateArea' returns 'Nothing'.
--
drawWindowGetUpdateArea :: DrawWindowClass self => self
 -> IO (Maybe Region) -- ^ returns the update area for @DrawWindow@
drawWindowGetUpdateArea self = do
  reg <- {# call gdk_window_get_update_area #} (toDrawWindow self)
  if reg==nullPtr then return Nothing else liftM Just (makeNewRegion reg)

-- | Temporarily freezes a drawWindow such that it won\'t receive expose events.
--  * The drawWindow will begin receiving expose events again when
--  'drawWindowThawUpdates'
-- is called. If 'drawWindowFreezeUpdates' has been called more than once,
-- 'drawWindowThawUpdates' must be called an equal number of times to begin
-- processing exposes.
--
drawWindowFreezeUpdates :: DrawWindowClass self => self -> IO ()
drawWindowFreezeUpdates self =
  {# call gdk_window_freeze_updates #}
     (toDrawWindow self)

-- | Thaws a drawWindow frozen with 'drawWindowFreezeUpdates'.
--
drawWindowThawUpdates :: DrawWindowClass self => self -> IO ()
drawWindowThawUpdates self =
  {# call gdk_window_thaw_updates #}
     (toDrawWindow self)

-- | Sends one or more expose events to @DrawWindow@.
--
-- * The areas in each expose
-- event will cover the entire update area for the window (see
-- 'drawWindowInvalidateRegion' for details). Normally Gtk calls
-- 'drawWindowProcessUpdates' on your behalf, so there's no need to call this
-- function unless you want to force expose events to be delivered immediately
-- and synchronously (vs. the usual case, where Gtk delivers them in an idle
-- handler). Occasionally this is useful to produce nicer scrolling behavior,
-- for example.
--
drawWindowProcessUpdates :: DrawWindowClass self => self
 -> Bool  -- ^ @updateChildren@ - whether to also process updates for child
          -- drawWindows
 -> IO ()
drawWindowProcessUpdates self updateChildren =
  {# call gdk_window_process_updates #}
     (toDrawWindow self)
     (fromBool updateChildren)

#if GTK_CHECK_VERSION(2,4,0)
-- | Setting @acceptFocus@ to @False@ hints the desktop environment that the
-- window doesn\'t want to receive input focus.
--
-- On X, it is the responsibility of the drawWindow manager to interpret this
-- hint. ICCCM-compliant drawWindow manager usually respect it.
--
-- * Available since Gdk version 2.4
--
drawWindowSetAcceptFocus :: DrawWindowClass self => self
 -> Bool  -- ^ @acceptFocus@ - @True@ if the drawWindow should receive input focus
 -> IO ()
drawWindowSetAcceptFocus self acceptFocus =
  {# call gdk_window_set_accept_focus #}
     (toDrawWindow self)
     (fromBool acceptFocus)
#endif

-- | Applies a shape mask to window. Pixels in window corresponding to set
--   bits in the mask will be visible; pixels in window corresponding to
--   unset bits in the mask will be transparent. This gives a non-rectangular
--   window.
--
-- * If @mask@ is @Nothing@, the shape mask will be unset, and the x\/y parameters
--   are not used. The @mask@ must be a bitmap, that is, a 'Pixmap' of depth
--   one.
--
-- * On the X11 platform, this uses an X server extension which is widely
--   available on most common platforms, but not available on very old
--   X servers, and occasionally the implementation will be buggy.
--   On servers without the shape extension, this function will do nothing.
--   On the Win32 platform the functionality is always present.
--
-- * This function works on both toplevel and child windows.
--
drawWindowShapeCombineMask :: DrawWindowClass self => self
 -> Maybe Pixmap -- ^ @mask@ - region of drawWindow to be non-transparent
 -> Int            -- ^ @offsetX@ - X position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> Int            -- ^ @offsetY@ - Y position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> IO ()
drawWindowShapeCombineMask self (Just (Pixmap mask)) offsetX offsetY =
  withForeignPtr mask $ \maskPtr ->
  {# call gdk_window_shape_combine_mask #}
     (toDrawWindow self)
     (castPtr maskPtr)
     (fromIntegral offsetX)
     (fromIntegral offsetY)
drawWindowShapeCombineMask self Nothing offsetX offsetY =
  {# call gdk_window_shape_combine_mask #}
     (toDrawWindow self)
     nullPtr
     (fromIntegral offsetX)
     (fromIntegral offsetY)

-- | Makes pixels in @DrawWindow@ outside @shapeRegion@ transparent.
--
-- * Makes pixels in @DrawWindow@ outside @shapeRegion@ transparent, so that
-- the window may be nonrectangular.
--
-- If @shapeRegion@ is 'Nothing', the shape will be unset, so the whole
-- 'DrawWindow' will be opaque again. The parameters @offsetX@ and @offsetY@
-- are ignored if @shapeRegion@ is 'Nothing'.
--
-- On the X11 platform, this uses an X server extension which is widely
-- available on most common platforms, but not available on very old X servers,
-- and occasionally the implementation will be buggy. On servers without the
-- shape extension, this function will do nothing.
--
-- This function works on both toplevel and child drawWindows.
--
drawWindowShapeCombineRegion :: DrawWindowClass self => self
 -> Maybe Region -- ^ @shapeRegion@ - region of drawWindow to be non-transparent
 -> Int            -- ^ @offsetX@ - X position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> Int            -- ^ @offsetY@ - Y position of @shapeRegion@ in @DrawWindow@
                   -- coordinates
 -> IO ()
drawWindowShapeCombineRegion self (Just reg) offsetX offsetY =
  {# call gdk_window_shape_combine_region #}
     (toDrawWindow self)
     reg
     (fromIntegral offsetX)
     (fromIntegral offsetY)
drawWindowShapeCombineRegion self Nothing offsetX offsetY =
  {# call gdk_window_shape_combine_region #}
     (toDrawWindow self)
     (Region nullForeignPtr)
     (fromIntegral offsetX)
     (fromIntegral offsetY)

-- | Sets the shape mask of @DrawWindow@ to the union of shape masks for all
-- children of @DrawWindow@, ignoring the shape mask of @DrawWindow@ itself. Contrast
-- with 'drawWindowMergeChildShapes' which includes the shape mask of @DrawWindow@ in
-- the masks to be merged.
--
drawWindowSetChildShapes :: DrawWindowClass self => self -> IO ()
drawWindowSetChildShapes self =
  {# call gdk_window_set_child_shapes #}
     (toDrawWindow self)

-- | Merges the shape masks for any child drawWindows into the shape mask for
-- @DrawWindow@. i.e. the union of all masks for @DrawWindow@ and its children will
-- become the new mask for @DrawWindow@. See 'drawWindowShapeCombineMask'.
--
-- This function is distinct from 'drawWindowSetChildShapes' because it includes
-- @DrawWindow@'s shape mask in the set of shapes to be merged.
--
drawWindowMergeChildShapes :: DrawWindowClass self => self -> IO ()
drawWindowMergeChildShapes self =
  {# call gdk_window_merge_child_shapes #}
     (toDrawWindow self)

-- Superseded by 'drawWindowGetPointerPos', won't be removed.
-- Obtains the current pointer position and modifier state.
--
-- * The position is
-- given in coordinates relative to the given window.
--
-- * The return value is @Just (same, x, y, mod)@ where @same@ is @True@
--   if the passed in window is the window over which the mouse currently
--   resides.
--
-- * The return value is @Nothing@ if the mouse cursor is over a different
--   application.
--
drawWindowGetPointer :: DrawWindowClass self => self
 -> IO (Maybe (Bool, Int, Int, [Modifier]))
drawWindowGetPointer self =
  alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \mPtr -> do
  winPtr <- {# call gdk_window_get_pointer #} (toDrawWindow self)
     xPtr yPtr mPtr
  if winPtr==nullPtr then return Nothing else do
  same <- withForeignPtr (unDrawWindow (toDrawWindow self)) $ \dPtr ->
          return (winPtr==dPtr)
  x <- peek xPtr
  y <- peek yPtr
  m <- peek mPtr
  return (Just (same, fromIntegral x, fromIntegral y,
                toFlags (fromIntegral m)))

-- | Obtains the current pointer position and modifier state.
--
-- * The position is
-- given in coordinates relative to the given window.
--
-- * The return value is @(Just win, x, y, mod)@ where @win@ is the
--   window over which the mouse currently resides and @mod@ denotes
--   the keyboard modifiers currently being depressed.
--
-- * The return value is @Nothing@ for the window if the mouse cursor is
--   not over a known window.
--
drawWindowGetPointerPos :: DrawWindowClass self => self
 -> IO (Maybe DrawWindow, Int, Int, [Modifier])
drawWindowGetPointerPos self =
  alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \mPtr -> do
  winPtr <- {# call gdk_window_get_pointer #} (toDrawWindow self)
     xPtr yPtr mPtr
  x <- peek xPtr
  y <- peek yPtr
  m <- peek mPtr
  mWin <- if winPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkDrawWindow (return winPtr)
  return (mWin, fromIntegral x, fromIntegral y, toFlags (fromIntegral m))

-- | Obtains the position of a window in screen coordinates.
--
-- You can use this to help convert a position between screen coordinates and
-- local 'DrawWindow' relative coordinates.
--
drawWindowGetOrigin :: DrawWindow
 -> IO (Int, Int) -- ^ @(x, y)@
drawWindowGetOrigin self =
  alloca $ \xPtr ->
  alloca $ \yPtr -> do
  {# call gdk_window_get_origin #}
    (toDrawWindow self)
    xPtr
    yPtr
  x <- peek xPtr
  y <- peek yPtr
  return (fromIntegral x, fromIntegral y)

-- | Get the handle to an exising window of the windowing system. The
-- passed-in handle is a reference to a native window, that is, an Xlib XID
-- for X windows and a HWND for Win32.
drawWindowForeignNew :: NativeWindowId -> IO (Maybe DrawWindow)
drawWindowForeignNew anid = maybeNull (makeNewGObject mkDrawWindow) $
  liftM castPtr $ {#call gdk_window_foreign_new#} (fromNativeWindowId anid)