Wrap image and font creation in Maybe

Wrap image and font creation in Maybe

{-# 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) * 4
  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}

{#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 cImage'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#}

{-# 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) * 4
  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}

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

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

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

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

{#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'} -> `()'#}

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

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

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

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


Slightly nicer code.

Slightly nicer code.

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Whisper
  ( closeWhisper, openWhisper, createWhisper
  , readHeader, readMetaData, readArchiveInfo
  , readArchive, readPoint
  , readArchives
  , updateWhisper
  , aiRetention, aiSize
  , AggregationType(..)
  , Header(..), MetaData(..), ArchiveInfo(..), Archive(..), Point(..)
  ) where

import Prelude hiding (Enum, fromEnum)

import Control.Applicative ((<$>), (<*>))
import Control.Exception (finally)
import Data.Bits ((.|.))
import Data.Function (on)
import Data.List (sortBy)
import Data.Word (Word32, Word64)
import Data.Storable.Endian (peekBE, pokeBE)
import Foreign.C.Types
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (castPtr, nullPtr, plusPtr, Ptr)
import Foreign.Storable
import System.IO (SeekMode(..))
import System.IO.Unsafe (unsafePerformIO)
import System.Posix (closeFd, defaultFileFlags, fileSize, getFdStatus, openFd, OpenMode(..))
import System.Posix.IO (fdSeek, fdWrite)
import System.Posix.Files (ownerReadMode, ownerWriteMode, unionFileModes)
import System.Posix.Types (Fd)

-- TODO Some Int are used for unsigned long, which is not correct.
-- TODO Replace peekElemOff with plusPtr by peekByteOff.
-- TODO Use fcntl to lock the file.
-- TODO Probably the header can be directly available in the Whisper data type
-- (probably it is almost always necessary to know the complete file layout (as
-- provided by the ArchiveInfo) to do any meaningful operation).

#include <sys/mman.h>

class Enum a where
  toEnum :: Integer -> a
  fromEnum :: a -> Integer

#c
enum curved_MMAP_WRAPPER
{ curved_MAP_SHARED = MAP_SHARED
};
#endc

{# enum curved_MMAP_WRAPPER as MMAP_WRAPPER {} with prefix = "curved_" #}

#c
enum curved_PROT_WRAPPER
{ curved_PROT_READ = PROT_READ
, curved_PROT_WRITE = PROT_WRITE
};
#endc

{# enum curved_PROT_WRAPPER as PROT_WRAPPER {} with prefix = "curved_" #}

data Whisper = Whisper { whisperPtr :: Ptr (), whisperFd :: Fd }

data Header = Header
  { hMetaData :: MetaData
  , hArchiveInfo :: [ArchiveInfo]
  }
  deriving Show

data MetaData = MetaData
  { mdAggregationType :: AggregationType
  , mdMaxRetention :: Int
  , mdXFilesFactor :: Float
  , mdArchiveCount :: Int
  }
  deriving Show

data ArchiveInfo = ArchiveInfo
  { aiOffset :: Int
  , aiSecondsPerPoint :: Int
  , aiPoints :: Int
  }
  deriving Show

aiRetention :: ArchiveInfo -> Int
aiRetention ArchiveInfo{..} = aiSecondsPerPoint * aiPoints

aiSize :: ArchiveInfo -> Int
aiSize ArchiveInfo{..} = aiPoints * sizeOf (undefined :: Point)

data AggregationType = Average | Sum | Last | Max | Min
  deriving Show

data Archive = Archive [Point]
  deriving Show

data Point = Point Int Double
  deriving Show

-- | Open a memory-mapped file.
openWhisper :: FilePath -> IO Whisper
openWhisper path = do
  fd <- openFd path ReadWrite Nothing defaultFileFlags
  flip finally (closeFd fd) $ do -- TODO Can we close the fd before unmmap'ing it ?
    stat <- getFdStatus fd
    let size = fileSize stat
    ptr <- {# call mmap #} nullPtr (fromIntegral size) (fromInteger $ fromEnum PROT_READ .|. fromEnum PROT_WRITE) (fromInteger $ fromEnum MAP_SHARED) (fromIntegral fd) 0
    if ptr == nullPtr
      then error "Data.Whisper.openWhisper: unable to mmap file."
      else return $ Whisper (castPtr ptr) fd

closeWhisper :: Whisper -> IO ()
closeWhisper (Whisper ptr fd) = do
  _ <- {# call munmap #} ptr (fromIntegral fd) -- TODO check error code
  return ()

-- | Create a memory-mapped file of the given size.
openWhisperSize :: FilePath -> Int -> IO Whisper
openWhisperSize path size = do
  fd <- openFd path ReadWrite (Just $ ownerReadMode `unionFileModes` ownerWriteMode) defaultFileFlags
  -- Write a dummy byte to size correctly the underlying file befor
  -- memory-mapping it.
  fdSeek fd AbsoluteSeek (fromIntegral $ size - 1) >>= print --TODO check return value ? check size > 0 ?
  fdWrite fd "\0" >>= print
  flip finally (closeFd fd) $ do -- TODO Can we close the fd before unmmap'ing it ?
    ptr <- {# call mmap #} nullPtr (fromIntegral size) (fromInteger $ fromEnum PROT_WRITE) (fromInteger $ fromEnum MAP_SHARED) (fromIntegral fd) 0 -- TODO | PROT_READ
    print ptr
    if ptr == nullPtr
      then error "Data.Whisper.openWhisperSize: unable to mmap file."
      else return $ Whisper ptr fd

readHeader :: Whisper -> IO Header
readHeader w = do
  md <- readMetaData w
  ai <- mapM (readArchiveInfo w) [0..fromIntegral (mdArchiveCount md) - 1]
  return $ Header md ai

readMetaData :: Whisper -> IO MetaData
readMetaData Whisper{..} = peek (castPtr whisperPtr)

readArchiveInfo :: Whisper -> Int -> IO ArchiveInfo
readArchiveInfo Whisper{..} n =
  peekElemOff (castPtr whisperPtr `plusPtr` sizeOf (undefined :: MetaData)) n

-- | Read the nth archive, considering it as a window ending at `timestamp`.
readArchive :: Whisper -> Int -> Timestamp -> IO Archive
readArchive w@Whisper{..} n timestamp = do
  ai@ArchiveInfo{..} <- readArchiveInfo w n -- TODO the archiveInfo is usually already read.
  if aiPoints <= 0
    then return $ Archive []
    else do
      -- The very first point presence indicates if data are present.
      Point ts _ <- readPoint w aiOffset 0
      if ts == 0
        then return $ Archive []
        else do
          -- The first point in the archive is used as a base point
          -- to index into the archive data.
          ps <- mapM (readPoint w aiOffset) [0..aiPoints - 1]
          let (after, before) = splitAt (slot ai ts timestamp) ps
          return . Archive $ lockstep ai timestamp $ before ++ after

-- TODO instead of passing the aiOffset, we could just pass the ArchiveInfo.
readPoint :: Whisper -> Int -> Int -> IO Point
readPoint Whisper{..} archiveOffset n =
  peekElemOff (castPtr whisperPtr `plusPtr` archiveOffset) n

readArchives :: Whisper -> Timestamp -> IO [Archive]
readArchives w timestamp = do
  Header{..} <- readHeader w
  mapM (flip (readArchive w) timestamp) [0..length hArchiveInfo - 1]

writeHeader :: Whisper -> Header -> IO ()
writeHeader w Header{..} = do
  writeMetaData w hMetaData
  mapM_ (uncurry $ writeArchiveInfo w) $ zip [0..] hArchiveInfo

writeMetaData :: Whisper -> MetaData -> IO ()
writeMetaData Whisper{..} = poke (castPtr whisperPtr)

writeArchiveInfo :: Whisper -> Int -> ArchiveInfo -> IO ()
writeArchiveInfo Whisper{..} n =
  pokeElemOff (castPtr whisperPtr `plusPtr` sizeOf (undefined :: MetaData)) n

writeArchive :: Whisper -> ArchiveInfo -> Archive -> IO ()
writeArchive w@Whisper{..} ArchiveInfo{..} (Archive points) =
  mapM_ (uncurry $ writePoint w aiOffset) $ zip [0..] points

writePoint :: Whisper -> Int -> Int -> Point -> IO ()
writePoint Whisper{..} archiveOffset n =
  pokeElemOff (castPtr whisperPtr `plusPtr` archiveOffset) n

writeArchives :: Whisper -> [ArchiveInfo] -> [Archive] -> IO ()
writeArchives w infos archives =
  mapM_ (uncurry $ writeArchive w) $ zip infos archives

createWhisper :: FilePath -> [(Int, Int)] -> Float -> AggregationType -> IO ()
createWhisper filename archiveInfos_ factor aggregation = do
  -- TODO archiveInfos_ can't be null.

  let archiveInfos = sortBy (compare `on` fst) archiveInfos_
      archiveInfos' = tail $ scanl toAI (ArchiveInfo (headerSize $ length archiveInfos) 1 0) archiveInfos
      retention = aiRetention $ last archiveInfos'
      meta = MetaData aggregation retention factor (length archiveInfos)
      header = Header meta archiveInfos'
      archives = map (Archive . flip replicate (Point 0 0) . snd) archiveInfos

  w@Whisper{..} <- openWhisperSize filename (headerSize (length archiveInfos) + sum (map snd archiveInfos) * sizeOf (undefined :: Point))
  writeHeader w header
  writeArchives w archiveInfos' archives
  closeWhisper w

-- | Given an ArchiveInfo and a timestamp, return its slot in the archive.
slot ArchiveInfo{..} base timestamp = (((timestamp - base) `div` aiSecondsPerPoint) + 1) `mod` aiPoints

slot' ArchiveInfo{..} base timestamp = ((timestamp - base) `div` aiSecondsPerPoint) `mod` aiPoints

start ai timestamp = timestamp - (timestamp `mod` aiSecondsPerPoint ai) - aiRetention ai + aiSecondsPerPoint ai

slotTimestamp ai timestamp = timestamp - (timestamp `mod` aiSecondsPerPoint ai)

lockstep ai@ArchiveInfo{..} timestamp points = zipWith f [s, s + aiSecondsPerPoint ..] points
  where s = start ai timestamp
        f ts (Point ts' value) | ts == ts' = Point ts value
                               | otherwise = Point 0 0

-- | sizeOf a complete header, given the number of archives.
headerSize :: Int -> Int
headerSize n = sizeOf (undefined :: MetaData) + sizeOf (undefined :: ArchiveInfo) * n

-- | Given the precision and number of points of an archive (i.e. its
-- ArchiveInfo without its offset), and its predecessor archive, create a
-- complete ArchiveInfo (i.e. with its offset).
toAI :: ArchiveInfo -> (Int, Int) -> ArchiveInfo
toAI ArchiveInfo{..} (precision, points) =
  ArchiveInfo (aiOffset + sizeOf (undefined :: Point) * aiPoints) precision points

type Timestamp = Int

updateWhisper :: Whisper -> Header -> Int -> Double -> IO ()
updateWhisper w@Whisper{..} header timestamp value = do
  let archiveIndex = 0 -- TODO correctly select thearchive to update and propagate the value.
      ai = hArchiveInfo header !! archiveIndex
      offset = aiOffset ai
  Point ts _ <- readPoint w offset 0
  -- TODO then patter of reading the first point and decide if the archive has already some data is reused in readArchive.
  -- (B.t.w. I don't think it was necessary: only the modulo (without the base timestamp) was enough. Any gain
  -- exists only for empty or almost emtpy files.
  if ts == 0
    then writePoint w offset 0 (Point (slotTimestamp ai timestamp) value)
    else do
      let i = slot' (hArchiveInfo header !! archiveIndex) ts timestamp
      writePoint w offset i (Point (slotTimestamp ai timestamp )value)

instance Storable MetaData where
  sizeOf _ =
    sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)
    + sizeOf (undefined :: CFloat)
    + sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = MetaData
    <$> peek (castPtr ptr)
    <*> peekWord32beAsNum (castPtr ptr `plusPtr` 4)
    <*> peekWord32beAsFloat (castPtr ptr `plusPtr` 8)
    <*> peekWord32beAsNum (castPtr ptr `plusPtr` 12)

  poke ptr MetaData{..} = do
    poke (castPtr ptr) mdAggregationType
    pokeBE (castPtr ptr `plusPtr` 4) (fromIntegral mdMaxRetention :: Word32)
    pokeBE (castPtr ptr `plusPtr` 8) (coerce mdXFilesFactor)
    pokeBE (castPtr ptr `plusPtr` 12) (fromIntegral mdArchiveCount :: Word32)
    where
    coerce :: Float -> Word32
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Word32

instance Storable ArchiveInfo where
  sizeOf _ =
    sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = ArchiveInfo
    <$> peekWord32beAsNum (castPtr ptr)
    <*> peekWord32beAsNum (castPtr ptr `plusPtr` 4)
    <*> peekWord32beAsNum (castPtr ptr `plusPtr` 8)

  poke ptr ArchiveInfo{..} = do
    pokeBE (castPtr ptr) (fromIntegral aiOffset :: Word32)
    pokeBE (castPtr ptr `plusPtr` 4) (fromIntegral aiSecondsPerPoint :: Word32)
    pokeBE (castPtr ptr `plusPtr` 8) (fromIntegral aiPoints :: Word32)

instance Storable AggregationType where
  sizeOf _ = sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = agg <$> peekBE (castPtr ptr :: Ptr Word32)
    where
    agg 1 = Average
    agg 2 = Sum
    agg 3 = Last
    agg 4 = Max
    agg 5 = Min
    agg _ = Average

  poke ptr a = pokeBE (castPtr ptr) $ agg a
    where
    agg Average = 1 :: Word32
    agg Sum = 2
    agg Last = 3
    agg Max = 4
    agg Min = 5

instance Storable Point where
  sizeOf _ = sizeOf (undefined :: Word32)
    + sizeOf (undefined :: CDouble)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = Point
    <$> peekWord32beAsNum (castPtr ptr)
    <*> peekWord64beAsDouble (castPtr ptr `plusPtr` 4)

  poke ptr (Point a b) = do
    pokeBE (castPtr ptr) (fromIntegral a :: Word32)
    pokeBE (castPtr ptr `plusPtr` 4) (coerce b)
    where
    coerce :: Double -> Word64
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Word64

peekWord32beAsNum :: Num a => Ptr Word32 -> IO a
peekWord32beAsNum ptr = fromIntegral <$> peekBE ptr

peekWord32beAsFloat :: Ptr Word32 -> IO Float
peekWord32beAsFloat ptr = coerce <$> peekBE ptr
  where
  coerce :: Word32 -> Float
  coerce x = unsafePerformIO $ with x $ \p ->
    peek (castPtr p) :: IO Float

peekWord64beAsDouble :: Ptr Word64 -> IO Double
peekWord64beAsDouble ptr = coerce <$> peekBE ptr
  where
  coerce :: Word64 -> Double
  coerce x = unsafePerformIO $ with x $ \p ->
    peek (castPtr p) :: IO Double

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Whisper
  ( closeWhisper, openWhisper, createWhisper
  , readHeader, readMetaData, readArchiveInfo
  , readArchive, readPoint
  , readArchives
  , updateWhisper
  , aiRetention, aiSize
  , AggregationType(..)
  , Header(..), MetaData(..), ArchiveInfo(..), Archive(..), Point(..)
  ) where

import Prelude hiding (Enum, fromEnum)

import Control.Exception (finally)
import Data.Bits ((.|.))
import Data.Function (on)
import Data.List (sortBy)
import Data.Word (Word32, Word64)
import Data.Storable.Endian (peekBE, pokeBE)
import Foreign.C.Types
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (castPtr, nullPtr, plusPtr, Ptr)
import Foreign.Storable
import System.IO (SeekMode(..))
import System.IO.Unsafe (unsafePerformIO)
import System.Posix (closeFd, defaultFileFlags, fileSize, getFdStatus, openFd, OpenMode(..))
import System.Posix.IO (fdSeek, fdWrite)
import System.Posix.Files (ownerReadMode, ownerWriteMode, unionFileModes)
import System.Posix.Types (Fd)

-- TODO Some Int are used for unsigned long, which is not correct.
-- TODO Replace peekElemOff with plusPtr by peekByteOff.
-- TODO Use fcntl to lock the file.
-- TODO Probably the header can be directly available in the Whisper data type
-- (probably it is almost always necessary to know the complete file layout (as
-- provided by the ArchiveInfo) to do any meaningful operation).

#include <sys/mman.h>

class Enum a where
  toEnum :: Integer -> a
  fromEnum :: a -> Integer

#c
enum curved_MMAP_WRAPPER
{ curved_MAP_SHARED = MAP_SHARED
};
#endc

{# enum curved_MMAP_WRAPPER as MMAP_WRAPPER {} with prefix = "curved_" #}

#c
enum curved_PROT_WRAPPER
{ curved_PROT_READ = PROT_READ
, curved_PROT_WRITE = PROT_WRITE
};
#endc

{# enum curved_PROT_WRAPPER as PROT_WRAPPER {} with prefix = "curved_" #}

data Whisper = Whisper { whisperPtr :: Ptr (), whisperFd :: Fd }

data Header = Header
  { hMetaData :: MetaData
  , hArchiveInfo :: [ArchiveInfo]
  }
  deriving Show

data MetaData = MetaData
  { mdAggregationType :: AggregationType
  , mdMaxRetention :: Int
  , mdXFilesFactor :: Float
  , mdArchiveCount :: Int
  }
  deriving Show

data ArchiveInfo = ArchiveInfo
  { aiOffset :: Int
  , aiSecondsPerPoint :: Int
  , aiPoints :: Int
  }
  deriving Show

aiRetention :: ArchiveInfo -> Int
aiRetention ArchiveInfo{..} = aiSecondsPerPoint * aiPoints

aiSize :: ArchiveInfo -> Int
aiSize ArchiveInfo{..} = aiPoints * sizeOf (undefined :: Point)

data AggregationType = Average | Sum | Last | Max | Min
  deriving Show

data Archive = Archive [Point]
  deriving Show

data Point = Point Int Double
  deriving Show

-- | Open a memory-mapped file.
openWhisper :: FilePath -> IO Whisper
openWhisper path = do
  fd <- openFd path ReadWrite Nothing defaultFileFlags
  flip finally (closeFd fd) $ do -- TODO Can we close the fd before unmmap'ing it ?
    stat <- getFdStatus fd
    let size = fileSize stat
    ptr <- {# call mmap #} nullPtr (fromIntegral size) (fromInteger $ fromEnum PROT_READ .|. fromEnum PROT_WRITE) (fromInteger $ fromEnum MAP_SHARED) (fromIntegral fd) 0
    if ptr == nullPtr
      then error "Data.Whisper.openWhisper: unable to mmap file."
      else return $ Whisper (castPtr ptr) fd

closeWhisper :: Whisper -> IO ()
closeWhisper (Whisper ptr fd) = do
  _ <- {# call munmap #} ptr (fromIntegral fd) -- TODO check error code
  return ()

-- | Create a memory-mapped file of the given size.
openWhisperSize :: FilePath -> Int -> IO Whisper
openWhisperSize path size = do
  fd <- openFd path ReadWrite (Just $ ownerReadMode `unionFileModes` ownerWriteMode) defaultFileFlags
  -- Write a dummy byte to size correctly the underlying file befor
  -- memory-mapping it.
  fdSeek fd AbsoluteSeek (fromIntegral $ size - 1) >>= print --TODO check return value ? check size > 0 ?
  fdWrite fd "\0" >>= print
  flip finally (closeFd fd) $ do -- TODO Can we close the fd before unmmap'ing it ?
    ptr <- {# call mmap #} nullPtr (fromIntegral size) (fromInteger $ fromEnum PROT_WRITE) (fromInteger $ fromEnum MAP_SHARED) (fromIntegral fd) 0 -- TODO | PROT_READ
    print ptr
    if ptr == nullPtr
      then error "Data.Whisper.openWhisperSize: unable to mmap file."
      else return $ Whisper ptr fd

readHeader :: Whisper -> IO Header
readHeader w = do
  md <- readMetaData w
  ai <- mapM (readArchiveInfo w) [0..fromIntegral (mdArchiveCount md) - 1]
  return $ Header md ai

readMetaData :: Whisper -> IO MetaData
readMetaData Whisper{..} = peek (castPtr whisperPtr)

readArchiveInfo :: Whisper -> Int -> IO ArchiveInfo
readArchiveInfo Whisper{..} n =
  peekElemOff (castPtr whisperPtr `plusPtr` sizeOf (undefined :: MetaData)) n

-- | Read the nth archive, considering it as a window ending at `timestamp`.
readArchive :: Whisper -> Int -> Timestamp -> IO Archive
readArchive w@Whisper{..} n timestamp = do
  ai@ArchiveInfo{..} <- readArchiveInfo w n -- TODO the archiveInfo is usually already read.
  if aiPoints <= 0
    then return $ Archive []
    else do
      -- The very first point presence indicates if data are present.
      Point ts _ <- readPoint w aiOffset 0
      if ts == 0
        then return $ Archive []
        else do
          -- The first point in the archive is used as a base point
          -- to index into the archive data.
          ps <- mapM (readPoint w aiOffset) [0..aiPoints - 1]
          let (after, before) = splitAt (slot ai ts timestamp) ps
          return . Archive $ lockstep ai timestamp $ before ++ after

-- TODO instead of passing the aiOffset, we could just pass the ArchiveInfo.
readPoint :: Whisper -> Int -> Int -> IO Point
readPoint Whisper{..} archiveOffset n =
  peekElemOff (castPtr whisperPtr `plusPtr` archiveOffset) n

readArchives :: Whisper -> Timestamp -> IO [Archive]
readArchives w timestamp = do
  Header{..} <- readHeader w
  mapM (flip (readArchive w) timestamp) [0..length hArchiveInfo - 1]

writeHeader :: Whisper -> Header -> IO ()
writeHeader w Header{..} = do
  writeMetaData w hMetaData
  mapM_ (uncurry $ writeArchiveInfo w) $ zip [0..] hArchiveInfo

writeMetaData :: Whisper -> MetaData -> IO ()
writeMetaData Whisper{..} = poke (castPtr whisperPtr)

writeArchiveInfo :: Whisper -> Int -> ArchiveInfo -> IO ()
writeArchiveInfo Whisper{..} n =
  pokeElemOff (castPtr whisperPtr `plusPtr` sizeOf (undefined :: MetaData)) n

writeArchive :: Whisper -> ArchiveInfo -> Archive -> IO ()
writeArchive w@Whisper{..} ArchiveInfo{..} (Archive points) =
  mapM_ (uncurry $ writePoint w aiOffset) $ zip [0..] points

writePoint :: Whisper -> Int -> Int -> Point -> IO ()
writePoint Whisper{..} archiveOffset n =
  pokeElemOff (castPtr whisperPtr `plusPtr` archiveOffset) n

writeArchives :: Whisper -> [ArchiveInfo] -> [Archive] -> IO ()
writeArchives w infos archives =
  mapM_ (uncurry $ writeArchive w) $ zip infos archives

createWhisper :: FilePath -> [(Int, Int)] -> Float -> AggregationType -> IO ()
createWhisper filename archiveInfos_ factor aggregation = do
  -- TODO archiveInfos_ can't be null.

  let archiveInfos = sortBy (compare `on` fst) archiveInfos_
      archiveInfos' = tail $ scanl toAI (ArchiveInfo (headerSize $ length archiveInfos) 1 0) archiveInfos
      retention = aiRetention $ last archiveInfos'
      meta = MetaData aggregation retention factor (length archiveInfos)
      header = Header meta archiveInfos'
      archives = map (Archive . flip replicate (Point 0 0) . snd) archiveInfos

  w@Whisper{..} <- openWhisperSize filename (headerSize (length archiveInfos) + sum (map snd archiveInfos) * sizeOf (undefined :: Point))
  writeHeader w header
  writeArchives w archiveInfos' archives
  closeWhisper w

-- | Given an ArchiveInfo and a timestamp, return its slot in the archive.
slot ArchiveInfo{..} base timestamp = (((timestamp - base) `div` aiSecondsPerPoint) + 1) `mod` aiPoints

slot' ArchiveInfo{..} base timestamp = ((timestamp - base) `div` aiSecondsPerPoint) `mod` aiPoints

start ai timestamp = timestamp - (timestamp `mod` aiSecondsPerPoint ai) - aiRetention ai + aiSecondsPerPoint ai

slotTimestamp ai timestamp = timestamp - (timestamp `mod` aiSecondsPerPoint ai)

lockstep ai@ArchiveInfo{..} timestamp points = zipWith f [s, s + aiSecondsPerPoint ..] points
  where s = start ai timestamp
        f ts (Point ts' value) | ts == ts' = Point ts value
                               | otherwise = Point 0 0

-- | sizeOf a complete header, given the number of archives.
headerSize :: Int -> Int
headerSize n = sizeOf (undefined :: MetaData) + sizeOf (undefined :: ArchiveInfo) * n

-- | Given the precision and number of points of an archive (i.e. its
-- ArchiveInfo without its offset), and its predecessor archive, create a
-- complete ArchiveInfo (i.e. with its offset).
toAI :: ArchiveInfo -> (Int, Int) -> ArchiveInfo
toAI ArchiveInfo{..} (precision, points) =
  ArchiveInfo (aiOffset + sizeOf (undefined :: Point) * aiPoints) precision points

type Timestamp = Int

updateWhisper :: Whisper -> Header -> Int -> Double -> IO ()
updateWhisper w@Whisper{..} header timestamp value = do
  let archiveIndex = 0 -- TODO correctly select thearchive to update and propagate the value.
      ai = hArchiveInfo header !! archiveIndex
      offset = aiOffset ai
  Point ts _ <- readPoint w offset 0
  -- TODO then patter of reading the first point and decide if the archive has already some data is reused in readArchive.
  -- (B.t.w. I don't think it was necessary: only the modulo (without the base timestamp) was enough. Any gain
  -- exists only for empty or almost emtpy files.
  if ts == 0
    then writePoint w offset 0 (Point (slotTimestamp ai timestamp) value)
    else do
      let i = slot' (hArchiveInfo header !! archiveIndex) ts timestamp
      writePoint w offset i (Point (slotTimestamp ai timestamp )value)

instance Storable MetaData where
  sizeOf _ =
    sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)
    + sizeOf (undefined :: CFloat)
    + sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = do
    a <- peek (castPtr ptr)
    b <- fromIntegral `fmap` peekBE (castPtr ptr `plusPtr` 4 :: Ptr Word32)
    c <- coerce `fmap` peekBE (castPtr ptr `plusPtr` 8)
    d <- fromIntegral `fmap` peekBE (castPtr ptr `plusPtr` 12 :: Ptr Word32)
    return $ MetaData a b c d
    where
    coerce :: Word32 -> Float
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Float

  poke ptr MetaData{..} = do
    poke (castPtr ptr) mdAggregationType
    pokeBE (castPtr ptr `plusPtr` 4) (fromIntegral mdMaxRetention :: Word32)
    pokeBE (castPtr ptr `plusPtr` 8) (coerce mdXFilesFactor)
    pokeBE (castPtr ptr `plusPtr` 12) (fromIntegral mdArchiveCount :: Word32)
    where
    coerce :: Float -> Word32
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Word32

instance Storable ArchiveInfo where
  sizeOf _ =
    sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)
    + sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = do
    a <- fromIntegral `fmap` peekBE (castPtr ptr :: Ptr Word32)
    b <- fromIntegral `fmap` peekBE (castPtr ptr `plusPtr` 4 :: Ptr Word32)
    c <- fromIntegral `fmap` peekBE (castPtr ptr `plusPtr` 8 :: Ptr Word32)
    return $ ArchiveInfo a b c

  poke ptr ArchiveInfo{..} = do
    pokeBE (castPtr ptr) (fromIntegral aiOffset :: Word32)
    pokeBE (castPtr ptr `plusPtr` 4) (fromIntegral aiSecondsPerPoint :: Word32)
    pokeBE (castPtr ptr `plusPtr` 8) (fromIntegral aiPoints :: Word32)

instance Storable AggregationType where
  sizeOf _ = sizeOf (undefined :: Word32)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = agg `fmap` peekBE (castPtr ptr :: Ptr Word32)
    where
    agg 1 = Average
    agg 2 = Sum
    agg 3 = Last
    agg 4 = Max
    agg 5 = Min
    agg _ = Average

  poke ptr a = pokeBE (castPtr ptr) $ agg a
    where
    agg Average = 1 :: Word32
    agg Sum = 2
    agg Last = 3
    agg Max = 4
    agg Min = 5

instance Storable Point where
  sizeOf _ = sizeOf (undefined :: Word32)
    + sizeOf (undefined :: CDouble)

  alignment _ = alignment (undefined :: Word32)

  peek ptr = do
    a <- fromIntegral `fmap` peekBE (castPtr ptr :: Ptr Word32)
    b <- coerce `fmap` peekBE (castPtr ptr `plusPtr` 4)
    return $ Point a b
    where
    coerce :: Word64 -> Double
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Double

  poke ptr (Point a b) = do
    pokeBE (castPtr ptr) (fromIntegral a :: Word32)
    pokeBE (castPtr ptr `plusPtr` 4) (coerce b)
    where
    coerce :: Double -> Word64
    coerce x = unsafePerformIO $ with x $ \p ->
      peek (castPtr p) :: IO Word64


SVG: provide implementation for GObjectClass

darcs-hash:20071031135016-ef904-ae7d2cb50b83f130196b7d9f6363402d04675cb3.gz

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.SVG
-- Copyright   :  (c) 2005 Duncan Coutts, Paolo Martini
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  gtk2hs-devel@lists.sourceforge.net
-- Stability   :  experimental
-- Portability :  portable
--
-- The SVG extension to the Cairo 2D graphics library.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.SVG (
  -- * Convenience API

  -- | These operations render an SVG image directly in the current 'Render'
  -- contect. Because they operate in the cairo 'Render' monad they are
  -- affected by the current transformation matrix. So it is possible, for
  -- example, to scale or rotate an SVG image.
  --
  -- In the following example we scale an SVG image to a unit square:
  --
  -- > let (width, height) = svgGetSize in
  -- > do scale (1/width) (1/height)
  -- >    svgRender svg

  svgRenderFromFile,
  svgRenderFromHandle,
  svgRenderFromString,

  -- * Standard API

  -- | With this API there are seperate functions for loading the SVG and
  -- rendering it. This allows us to be more effecient in the case that an SVG
  -- image is used many times - since it can be loaded just once and rendered
  -- many times. With the convenience API above the SVG would be parsed and
  -- processed each time it is drawn.

  SVG,
  svgRender,
  svgGetSize,

  -- ** Block scoped versions

  -- | These versions of the SVG loading operations give temporary access
  -- to the 'SVG' object within the scope of the handler function. These
  -- operations guarantee that the resources for the SVG object are deallocated
  -- at the end of the handler block. If this form of resource allocation is
  -- too restrictive you can use the GC-managed versions below.
  --
  -- These versions are ofen used in the following style:
  --
  -- > withSvgFromFile "foo.svg" $ \svg -> do
  -- >   ...
  -- >   svgRender svg
  -- >   ...

  withSvgFromFile,
  withSvgFromHandle,
  withSvgFromString,

  -- ** GC-managed versions

  -- | These versions of the SVG loading operations use the standard Haskell
  -- garbage collector to manage the resources associated with the 'SVG' object.
  -- As such they are more convenient to use but the GC cannot give
  -- strong guarantees about when the resources associated with the 'SVG' object
  -- will be released. In most circumstances this is not a problem, especially
  -- if the SVG files being used are not very big.

  svgNewFromFile,
  svgNewFromHandle,
  svgNewFromString,
  ) where

import Control.Monad (when)
import Foreign
import Foreign.C
import Control.Monad.Reader (ask, liftIO)
import System.IO (Handle, openFile, IOMode(ReadMode), hGetBuf)

import System.Glib.GError (GError(GError), checkGError)
import System.Glib.GObject (GObjectClass(..), constructNewGObject, unGObject, mkGObject)

import Graphics.Rendering.Cairo.Internal (Render, bracketR)
{# import Graphics.Rendering.Cairo.Types #} (Cairo(Cairo))

{# context lib="librsvg" prefix="rsvg_handle" #}

---------------------
-- Types
--

{# pointer *RsvgHandle as SVG foreign newtype #}

mkSVG = SVG
unSVG (SVG o) = o

instance GObjectClass SVG where
  toGObject = mkGObject . castForeignPtr . unSVG
  unsafeCastGObject = mkSVG . castForeignPtr . unGObject

---------------------
-- Basic API
--

-- block scoped versions

withSvgFromFile :: FilePath -> (SVG -> Render a) -> Render a
withSvgFromFile file action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromFile file svg
    action svg

withSvgFromHandle :: Handle -> (SVG -> Render a) -> Render a
withSvgFromHandle hnd action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromHandle hnd svg
    action svg

withSvgFromString :: String -> (SVG -> Render a) -> Render a
withSvgFromString str action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromString str svg
    action svg

withSVG :: (SVG -> Render a) -> Render a
withSVG =
  bracketR (do
             {# call g_type_init #}
             svgPtr <- {# call unsafe new #}
             svgPtr' <- newForeignPtr_ svgPtr
             return (SVG svgPtr'))
          (\(SVG fptr) -> withForeignPtr fptr $ \ptr ->
                            {# call unsafe g_object_unref #} (castPtr ptr))

-- GC managed versions

svgNewFromFile :: FilePath -> IO SVG
svgNewFromFile file = do
  svg <- svgNew
  svgParseFromFile file svg
  return svg

svgNewFromHandle :: Handle -> IO SVG
svgNewFromHandle hnd = do
  svg <- svgNew
  svgParseFromHandle hnd svg
  return svg

svgNewFromString :: String -> IO SVG
svgNewFromString str = do
  svg <- svgNew
  svgParseFromString str svg
  return svg

svgNew :: IO SVG
svgNew = do
  {# call g_type_init #}
  constructNewGObject SVG {# call unsafe new #}

-- internal implementation

svgParseFromFile :: FilePath -> SVG -> IO ()
svgParseFromFile file svg = do
  hnd <- openFile file ReadMode
  svgParseFromHandle hnd svg

svgParseFromHandle :: Handle -> SVG -> IO ()
svgParseFromHandle hnd svg =
  allocaBytes 4096 $ \bufferPtr -> do
  let loop = do
        count <- hGetBuf hnd bufferPtr 4096
        when (count > 0)
             (checkStatus $ {# call unsafe rsvg_handle_write #}
                svg (castPtr bufferPtr) (fromIntegral count))
        when (count == 4096) loop
  loop
  checkStatus $ {# call unsafe rsvg_handle_close #} svg

svgParseFromString :: String -> SVG -> IO ()
svgParseFromString str svg = do
  let loop ""  = return ()
      loop str =
        case splitAt 4096 str of
          (chunk, str') -> do
            withCStringLen chunk $ \(chunkPtr, len) ->
              checkStatus $ {# call unsafe rsvg_handle_write #}
                svg (castPtr chunkPtr) (fromIntegral len)
            loop str'
  loop str
  checkStatus $ {# call unsafe rsvg_handle_close #} svg

-- actually render it

svgRender :: SVG -> Render ()
svgRender svg = do
  cr <- ask
  liftIO $ {# call unsafe render_cairo #} svg cr

-- | Get the width and height of the SVG image.
--
svgGetSize ::
    SVG
 -> (Int, Int) -- ^ @(width, height)@
svgGetSize svg = unsafePerformIO $
  allocaBytes {# sizeof RsvgDimensionData #} $ \dimentionsPtr -> do
  {# call unsafe get_dimensions #} svg dimentionsPtr
  width  <- {# get RsvgDimensionData->width  #} dimentionsPtr
  height <- {# get RsvgDimensionData->height #} dimentionsPtr
  return (fromIntegral width, fromIntegral height)

---------------------
-- Convenience API
--

svgRenderFromFile :: FilePath -> Render ()
svgRenderFromFile file = withSvgFromFile file svgRender

svgRenderFromHandle :: Handle -> Render ()
svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender

svgRenderFromString :: String -> Render ()
svgRenderFromString str = withSvgFromString str svgRender

---------------------
-- Utils
--

checkStatus :: (Ptr (Ptr ()) -> IO CInt) -> IO ()
checkStatus action =
  checkGError (\ptr -> action ptr >> return ())
    (\(GError domain code msg) -> fail ("svg cairo error: " ++ msg))

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.SVG
-- Copyright   :  (c) 2005 Duncan Coutts, Paolo Martini
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  gtk2hs-devel@lists.sourceforge.net
-- Stability   :  experimental
-- Portability :  portable
--
-- The SVG extension to the Cairo 2D graphics library.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.SVG (
  -- * Convenience API

  -- | These operations render an SVG image directly in the current 'Render'
  -- contect. Because they operate in the cairo 'Render' monad they are
  -- affected by the current transformation matrix. So it is possible, for
  -- example, to scale or rotate an SVG image.
  --
  -- In the following example we scale an SVG image to a unit square:
  --
  -- > let (width, height) = svgGetSize in
  -- > do scale (1/width) (1/height)
  -- >    svgRender svg

  svgRenderFromFile,
  svgRenderFromHandle,
  svgRenderFromString,

  -- * Standard API

  -- | With this API there are seperate functions for loading the SVG and
  -- rendering it. This allows us to be more effecient in the case that an SVG
  -- image is used many times - since it can be loaded just once and rendered
  -- many times. With the convenience API above the SVG would be parsed and
  -- processed each time it is drawn.

  SVG,
  svgRender,
  svgGetSize,

  -- ** Block scoped versions

  -- | These versions of the SVG loading operations give temporary access
  -- to the 'SVG' object within the scope of the handler function. These
  -- operations guarantee that the resources for the SVG object are deallocated
  -- at the end of the handler block. If this form of resource allocation is
  -- too restrictive you can use the GC-managed versions below.
  --
  -- These versions are ofen used in the following style:
  --
  -- > withSvgFromFile "foo.svg" $ \svg -> do
  -- >   ...
  -- >   svgRender svg
  -- >   ...

  withSvgFromFile,
  withSvgFromHandle,
  withSvgFromString,

  -- ** GC-managed versions

  -- | These versions of the SVG loading operations use the standard Haskell
  -- garbage collector to manage the resources associated with the 'SVG' object.
  -- As such they are more convenient to use but the GC cannot give
  -- strong guarantees about when the resources associated with the 'SVG' object
  -- will be released. In most circumstances this is not a problem, especially
  -- if the SVG files being used are not very big.

  svgNewFromFile,
  svgNewFromHandle,
  svgNewFromString,
  ) where

import Control.Monad (when)
import Foreign
import Foreign.C
import Control.Monad.Reader (ask, liftIO)
import System.IO (Handle, openFile, IOMode(ReadMode), hGetBuf)

import System.Glib.GError (GError(GError), checkGError)
import System.Glib.GObject (GObjectClass, constructNewGObject)

import Graphics.Rendering.Cairo.Internal (Render, bracketR)
{# import Graphics.Rendering.Cairo.Types #} (Cairo(Cairo))

{# context lib="librsvg" prefix="rsvg_handle" #}

---------------------
-- Types
--

{# pointer *RsvgHandle as SVG foreign newtype #}

instance GObjectClass SVG

---------------------
-- Basic API
--

-- block scoped versions

withSvgFromFile :: FilePath -> (SVG -> Render a) -> Render a
withSvgFromFile file action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromFile file svg
    action svg

withSvgFromHandle :: Handle -> (SVG -> Render a) -> Render a
withSvgFromHandle hnd action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromHandle hnd svg
    action svg

withSvgFromString :: String -> (SVG -> Render a) -> Render a
withSvgFromString str action =
  withSVG $ \svg -> do
    liftIO $ svgParseFromString str svg
    action svg

withSVG :: (SVG -> Render a) -> Render a
withSVG =
  bracketR (do
             {# call g_type_init #}
             svgPtr <- {# call unsafe new #}
             svgPtr' <- newForeignPtr_ svgPtr
             return (SVG svgPtr'))
          (\(SVG fptr) -> withForeignPtr fptr $ \ptr ->
                            {# call unsafe g_object_unref #} (castPtr ptr))

-- GC managed versions

svgNewFromFile :: FilePath -> IO SVG
svgNewFromFile file = do
  svg <- svgNew
  svgParseFromFile file svg
  return svg

svgNewFromHandle :: Handle -> IO SVG
svgNewFromHandle hnd = do
  svg <- svgNew
  svgParseFromHandle hnd svg
  return svg

svgNewFromString :: String -> IO SVG
svgNewFromString str = do
  svg <- svgNew
  svgParseFromString str svg
  return svg

svgNew :: IO SVG
svgNew = do
  {# call g_type_init #}
  constructNewGObject SVG {# call unsafe new #}

-- internal implementation

svgParseFromFile :: FilePath -> SVG -> IO ()
svgParseFromFile file svg = do
  hnd <- openFile file ReadMode
  svgParseFromHandle hnd svg

svgParseFromHandle :: Handle -> SVG -> IO ()
svgParseFromHandle hnd svg =
  allocaBytes 4096 $ \bufferPtr -> do
  let loop = do
        count <- hGetBuf hnd bufferPtr 4096
        when (count > 0)
             (checkStatus $ {# call unsafe rsvg_handle_write #}
                svg (castPtr bufferPtr) (fromIntegral count))
        when (count == 4096) loop
  loop
  checkStatus $ {# call unsafe rsvg_handle_close #} svg

svgParseFromString :: String -> SVG -> IO ()
svgParseFromString str svg = do
  let loop ""  = return ()
      loop str =
        case splitAt 4096 str of
          (chunk, str') -> do
            withCStringLen chunk $ \(chunkPtr, len) ->
              checkStatus $ {# call unsafe rsvg_handle_write #}
                svg (castPtr chunkPtr) (fromIntegral len)
            loop str'
  loop str
  checkStatus $ {# call unsafe rsvg_handle_close #} svg

-- actually render it

svgRender :: SVG -> Render ()
svgRender svg = do
  cr <- ask
  liftIO $ {# call unsafe render_cairo #} svg cr

-- | Get the width and height of the SVG image.
--
svgGetSize ::
    SVG
 -> (Int, Int) -- ^ @(width, height)@
svgGetSize svg = unsafePerformIO $
  allocaBytes {# sizeof RsvgDimensionData #} $ \dimentionsPtr -> do
  {# call unsafe get_dimensions #} svg dimentionsPtr
  width  <- {# get RsvgDimensionData->width  #} dimentionsPtr
  height <- {# get RsvgDimensionData->height #} dimentionsPtr
  return (fromIntegral width, fromIntegral height)

---------------------
-- Convenience API
--

svgRenderFromFile :: FilePath -> Render ()
svgRenderFromFile file = withSvgFromFile file svgRender

svgRenderFromHandle :: Handle -> Render ()
svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender

svgRenderFromString :: String -> Render ()
svgRenderFromString str = withSvgFromString str svgRender

---------------------
-- Utils
--

checkStatus :: (Ptr (Ptr ()) -> IO CInt) -> IO ()
checkStatus action =
  checkGError (\ptr -> action ptr >> return ())
    (\(GError domain code msg) -> fail ("svg cairo error: " ++ msg))


SVG: provide implementation for GObjectClass


fix typo

{-# LANGUAGE ForeignFunctionInterface #-}

#include "puz.h"

module Codec.Game.Puz.Internal where

import Foreign
import Foreign.Ptr
import Foreign.C

{# pointer *puz_head_t as PuzHead foreign newtype #}
{# pointer *puzzle_t as Puz foreign newtype #}

{# enum define PuzType
   { PUZ_FILE_BINARY as PuzTypeBinary
   , PUZ_FILE_TEXT as PuzTypeText
   , PUZ_FILE_UNKNOWN as PuzTypeUnknown
   }
   deriving (Eq,Show)
 #}

-- XXX is this really freeing the right thing?  How could I tell?
marshallPuz :: Ptr Puz -> IO Puz
marshallPuz pp = do fp <- newForeignPtr finalizerFree pp
                    return $ Puz fp

-- custom marshallers
-- IN
alwaysUseIn :: a -> (a -> b) -> b
alwaysUseIn a f = f a

nullIn :: (Ptr a -> IO b) -> IO b
nullIn = alwaysUseIn nullPtr

puzTypeIn :: (CInt -> IO b) -> IO b
puzTypeIn = alwaysUseIn $ cIntConv $ fromEnum PuzTypeUnknown

puzIn :: Puz -> (Ptr Puz -> IO b) -> IO b
puzIn (Puz fp) = withForeignPtr fp

-- OUT
cerrToBool :: CInt -> Bool
cerrToBool = (0 ==)

cintToBool :: CInt -> Bool
cintToBool = (1 ==)

{- puz struct creation, initialization -}

-- XXX I think we don't actually need puz_init because puz_load also mallocs
-- and accepts null
{# fun puz_init as puzCreate
   {nullIn- `Ptr Puz'} -> `Puz' marshallPuz* #}

{# fun puz_load as puzLoad
   { nullIn- `Ptr Puz'
   , puzTypeIn- `PuzType'
   , id `Ptr CUChar'
   , `Int'
   } ->
   `Puz' marshallPuz*
 #}

{- check sum checking, generation -}
{# fun puz_cksums_calc as puzCksumsCalc
   { id `Ptr Puz' } -> `()'
 #}

{# fun puz_cksums_check as puzCksumsCheck
   { id `Ptr Puz' } -> `Bool' cerrToBool
 #}

{# fun puz_cksums_commit as puzCksumsCommit
   { id `Ptr Puz' } -> `()'
 #}

{- accessors -}
-- XXX actually the return guys on the sets check errors

{# fun puz_width_get as puzGetWidth
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_width_set as puzSetWidth
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_height_get as puzGetHeight
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_height_set as puzSetHeight
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_solution_get as puzGetSolution
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_solution_set as puzSetSolution
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_grid_get as puzGetGrid
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_grid_set as puzSetGrid
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_title_get as puzGetTitle
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_title_set as puzSetTitle
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_author_get as puzGetAuthor
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_author_set as puzSetAuthor
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_copyright_get as puzGetCopyright
   { puzIn* `Puz'} -> `Ptr CUChar' id
 #}

{# fun puz_copyright_set as puzSetCopyright
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_clue_count_get as puzGetClueCount
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_clue_count_set as puzSetClueCount
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_clue_get as puzGetClue
   { puzIn* `Puz'
   , `Int'
   } ->
   `Ptr CUChar' id
 #}

{# fun puz_clue_set as puzSetClue
   { puzIn* `Puz'
   , `Int'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_notes_get as puzGetNotes
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_notes_set as puzSetNotes
   { puzIn* `Puz'
   , id `Ptr CUChar' }
   ->
   `()'
 #}

------
------ C2HS stuff - why isn't there a C2HS module
------

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

{-# LANGUAGE ForeignFunctionInterface #-}

#include "puz.h"

module Codec.Game.Puz.Internal where

import Foreign
import Foreign.Ptr
import Foreign.C

{# pointer *puz_head_t as PuzHead foreign newtype #}
{# pointer *puzzle_t as Puz foreign newtype #}

{# enum define PuzType
   { PUZ_FILE_BINARY as PuzTypeBinary
   , PUZ_FILE_TEXT as PuzTypeText
   , PUZ_FILE_UNKNOWN as PuzTypeUnknown
   }
   deriving (Eq,Show)
 #}

-- XXX is this really freeing the right thing?  How could I tell?
marshallPuz :: Ptr Puz -> IO Puz
marshallPuz pp = do fp <- newForeignPtr finalizerFree pp
                    return $ Puz fp

-- custom marshallers
-- IN
alwaysUseIn :: a -> (a -> b) -> b
alwaysUseIn a f = f a

nullIn :: (Ptr a -> IO b) -> IO b
nullIn = alwaysUseIn nullPtr

puzTypeIn :: (CInt -> IO b) -> IO b
puzTypeIn = alwaysUseIn $ cIntConv $ fromEnum PuzTypeUnknown

puzIn :: Puz -> (Ptr Puz -> IO b) -> IO b
puzIn (Puz fp) = withForeignPtr fp

-- OUT
cerrToBool :: CInt -> Bool
cerrToBool = (0 ==)

cintToBool :: Cint -> Bool
cintToBool = (1 ==)

{- puz struct creation, initialization -}

-- XXX I think we don't actually need puz_init because puz_load also mallocs
-- and accepts null
{# fun puz_init as puzCreate
   {nullIn- `Ptr Puz'} -> `Puz' marshallPuz* #}

{# fun puz_load as puzLoad
   { nullIn- `Ptr Puz'
   , puzTypeIn- `PuzType'
   , id `Ptr CUChar'
   , `Int'
   } ->
   `Puz' marshallPuz*
 #}

{- check sum checking, generation -}
{# fun puz_cksums_calc as puzCksumsCalc
   { id `Ptr Puz' } -> `()'
 #}

{# fun puz_cksums_check as puzCksumsCheck
   { id `Ptr Puz' } -> `Bool' cerrToBool
 #}

{# fun puz_cksums_commit as puzCksumsCommit
   { id `Ptr Puz' } -> `()'
 #}

{- accessors -}
-- XXX actually the return guys on the sets check errors

{# fun puz_width_get as puzGetWidth
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_width_set as puzSetWidth
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_height_get as puzGetHeight
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_height_set as puzSetHeight
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_solution_get as puzGetSolution
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_solution_set as puzSetSolution
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_grid_get as puzGetGrid
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_grid_set as puzSetGrid
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_title_get as puzGetTitle
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_title_set as puzSetTitle
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_author_get as puzGetAuthor
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_author_set as puzSetAuthor
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_copyright_get as puzGetCopyright
   { puzIn* `Puz'} -> `Ptr CUChar' id
 #}

{# fun puz_copyright_set as puzSetCopyright
   { puzIn* `Puz'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_clue_count_get as puzGetClueCount
   { puzIn* `Puz' } -> `Int'
 #}

{# fun puz_clue_count_set as puzSetClueCount
   { puzIn* `Puz'
   , `Int'
   } ->
   `()'
 #}

{# fun puz_clue_get as puzGetClue
   { puzIn* `Puz'
   , `Int'
   } ->
   `Ptr CUChar' id
 #}

{# fun puz_clue_set as puzSetClue
   { puzIn* `Puz'
   , `Int'
   , id `Ptr CUChar'
   } ->
   `()'
 #}

{# fun puz_notes_get as puzGetNotes
   { puzIn* `Puz' } -> `Ptr CUChar' id
 #}

{# fun puz_notes_set as puzSetNotes
   { puzIn* `Puz'
   , id `Ptr CUChar' }
   ->
   `()'
 #}

------
------ C2HS stuff - why isn't there a C2HS module
------

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral


[project @ 2002-07-17 16:02:09 by juhp] (scrolledWindowNew): Make it maybe take Adjustments, passing a null ptr when Nothing is given.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget ScrolledWindow@
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/17 16:02:09 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * @ScrolledWindow is a container that adds scroll bars to its child. Some
--   widgets have native scrolling support, in which case the scrolling action
--   is performed by the child itself (e.g. a TreeView widget does this by only
--   moving the table part and not the titles of a table). If a widget does
--   not support native scrolling it has to be put into a @TreeView widget.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module ScrolledWindow(
  ScrolledWindow,
  ScrolledWindowClass,
  castToScrolledWindow,
  scrolledWindowNew,
  scrolledWindowGetHAdjustment,
  scrolledWindowGetVAdjustment,
  PolicyType(..),
  scrolledWindowSetPolicy,
  scrolledWindowAddWithViewport,
  CornerType(..),
  scrolledWindowSetPlacement,
  ShadowType(..),
  scrolledWindowSetShadowType,
  scrolledWindowSetHAdjustment,
  scrolledWindowSetVAdjustment,
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PolicyType(..), CornerType(..), ShadowType(..))
import Maybe    (fromMaybe)
import Structs  (nullForeignPtr)

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

-- methods

-- @constructor scrolledWindowNew@ Create a new @ref type ScrolledWindow@.
--
scrolledWindowNew :: Maybe Adjustment -> Maybe Adjustment -> IO ScrolledWindow
scrolledWindowNew hAdj vAdj = makeNewObject mkScrolledWindow $ liftM castPtr $
  {#call unsafe scrolled_window_new#} (fromMAdj hAdj) (fromMAdj vAdj)
 where
 fromMAdj :: Maybe Adjustment -> Adjustment
 fromMAdj = fromMaybe $ mkAdjustment nullForeignPtr

-- @method scrolledWindowGetHAdjustment@ Retrieve the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetHAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetHAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_hadjustment#} (toScrolledWindow w)

-- @method scrolledWindowGetVAdjustment@ Retrieve the vertical
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetVAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetVAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_vadjustment#} (toScrolledWindow w)

-- @method scrolledWindowSetPolicy@ Specify if the scrollbars should vanish if
-- the child size is sufficiently small.
--
scrolledWindowSetPolicy :: ScrolledWindowClass w => w -> PolicyType ->
                           PolicyType -> IO ()
scrolledWindowSetPolicy w hPol vPol = {#call scrolled_window_set_policy#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) hPol)
  ((fromIntegral.fromEnum) vPol)

-- @method scrolledWindowAddWithViewport@ Add a child widget without native
-- scrolling support to this @ref type ScrolledWindow@.
--
scrolledWindowAddWithViewport :: (ScrolledWindowClass w, WidgetClass wid) =>
                                 w -> wid -> IO ()
scrolledWindowAddWithViewport w wid =
  {#call scrolled_window_add_with_viewport#} (toScrolledWindow w)
  (toWidget wid)

-- @method scrolledWindowSetPlacement@ Specify where the scrollbars should be
-- placed.
--
scrolledWindowSetPlacement :: ScrolledWindowClass w => w -> CornerType -> IO ()
scrolledWindowSetPlacement w ct =
  {#call scrolled_window_set_placement#} (toScrolledWindow w)
  ((fromIntegral.fromEnum) ct)

-- @method scrolledWindowSetShadowType@ Specify if and how an outer frame
-- should be drawn around the child.
--
scrolledWindowSetShadowType :: ScrolledWindowClass w => w -> ShadowType ->
                               IO ()
scrolledWindowSetShadowType w st = {#call scrolled_window_set_shadow_type#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) st)

-- @method scrolledWindowSetHAdjustment@ Set the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowSetHAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetHAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- @method scrolledWindowSetVAdjustment@ Set the vertical @ref arg Adjustment@
-- of the @ref type ScrolledWindow@.
--
scrolledWindowSetVAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetVAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget ScrolledWindow@
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.2 $ from $Date: 2002/05/24 09:43:25 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file 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 General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * @ScrolledWindow is a container that adds scroll bars to its child. Some
--   widgets have native scrolling support, in which case the scrolling action
--   is performed by the child itself (e.g. a TreeView widget does this by only
--   moving the table part and not the titles of a table). If a widget does
--   not support native scrolling it has to be put into a @TreeView widget.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module ScrolledWindow(
  ScrolledWindow,
  ScrolledWindowClass,
  castToScrolledWindow,
  scrolledWindowNew,
  scrolledWindowGetHAdjustment,
  scrolledWindowGetVAdjustment,
  PolicyType(..),
  scrolledWindowSetPolicy,
  scrolledWindowAddWithViewport,
  CornerType(..),
  scrolledWindowSetPlacement,
  ShadowType(..),
  scrolledWindowSetShadowType,
  scrolledWindowSetHAdjustment,
  scrolledWindowSetVAdjustment,
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PolicyType(..), CornerType(..), ShadowType(..))

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

-- methods

-- @constructor scrolledWindowNew@ Create a new @ref type ScrolledWindow@.
--
scrolledWindowNew :: Adjustment -> Adjustment -> IO ScrolledWindow
scrolledWindowNew vAdj hAdj = makeNewObject mkScrolledWindow $ liftM castPtr $
  {#call unsafe scrolled_window_new#} hAdj vAdj

-- @method scrolledWindowGetHAdjustment@ Retrieve the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetHAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetHAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_hadjustment#} (toScrolledWindow w)

-- @method scrolledWindowGetVAdjustment@ Retrieve the vertical
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowGetVAdjustment :: ScrolledWindowClass w => w -> IO Adjustment
scrolledWindowGetVAdjustment w = makeNewObject mkAdjustment $
  {#call unsafe scrolled_window_get_vadjustment#} (toScrolledWindow w)

-- @method scrolledWindowSetPolicy@ Specify if the scrollbars should vanish if
-- the child size is sufficiently small.
--
scrolledWindowSetPolicy :: ScrolledWindowClass w => w -> PolicyType ->
                           PolicyType -> IO ()
scrolledWindowSetPolicy w hPol vPol = {#call scrolled_window_set_policy#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) hPol)
  ((fromIntegral.fromEnum) vPol)

-- @method scrolledWindowAddWithViewport@ Add a child widget without native
-- scrolling support to this @ref type ScrolledWindow@.
--
scrolledWindowAddWithViewport :: (ScrolledWindowClass w, WidgetClass wid) =>
                                 w -> wid -> IO ()
scrolledWindowAddWithViewport w wid =
  {#call scrolled_window_add_with_viewport#} (toScrolledWindow w)
  (toWidget wid)

-- @method scrolledWindowSetPlacement@ Specify where the scrollbars should be
-- placed.
--
scrolledWindowSetPlacement :: ScrolledWindowClass w => w -> CornerType -> IO ()
scrolledWindowSetPlacement w ct =
  {#call scrolled_window_set_placement#} (toScrolledWindow w)
  ((fromIntegral.fromEnum) ct)

-- @method scrolledWindowSetShadowType@ Specify if and how an outer frame
-- should be drawn around the child.
--
scrolledWindowSetShadowType :: ScrolledWindowClass w => w -> ShadowType ->
                               IO ()
scrolledWindowSetShadowType w st = {#call scrolled_window_set_shadow_type#}
  (toScrolledWindow w) ((fromIntegral.fromEnum) st)

-- @method scrolledWindowSetHAdjustment@ Set the horizontal
-- @ref arg Adjustment@ of the @ref type ScrolledWindow@.
--
scrolledWindowSetHAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetHAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj

-- @method scrolledWindowSetVAdjustment@ Set the vertical @ref arg Adjustment@
-- of the @ref type ScrolledWindow@.
--
scrolledWindowSetVAdjustment :: ScrolledWindowClass w => w -> Adjustment ->
                                IO ()
scrolledWindowSetVAdjustment w adj = {#call scrolled_window_set_hadjustment#}
  (toScrolledWindow w) adj