Added loadImage8 and loadColorImage8 functions for loading 8-bit images

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving #-}
#include "cvWrapLEO.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

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

-- Colorspaces
data GrayScale
data RGB
data RGB_Channel = Red | Green | Blue deriving (Eq,Ord,Enum)
data RGBA
data LAB
data LAB_Channel = LAB_L | LAB_A | LAB_B deriving (Eq,Ord,Enum)
type family ChannelOf a :: *
type instance ChannelOf RGB_Channel = RGB
type instance ChannelOf LAB_Channel = LAB

-- Bit Depths
type D8  = Word8
type D32 = Float
type D64 = Double

newtype Image channels depth = S BareImage

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

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

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

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

freeBareImage ptr = with ptr {#call cvReleaseImage#}

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

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

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

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

unImage (S (BareImage fptr)) = fptr

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

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

-- Load Image as grayscale image.

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

class Loadable a where
    readFromFile :: FilePath -> IO a

instance Loadable ((Image GrayScale D32)) where
    readFromFile fp = do
        e <- loadImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D32)) where
    readFromFile fp = do
        e <- loadColorImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

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

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

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

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

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

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

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

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

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

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

class GetPixel a where
    type P a :: *
    getPixel   :: (Int,Int) -> a -> P a

-- #define FGET(img,x,y) (((float *)((img)->imageData + (y)*(img)->widthStep))[(x)])
instance GetPixel (Image GrayScale D32) where
    type P (Image GrayScale D32) = D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float)

{-#INLINE getPixelOld#-}
getPixelOld (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $
         withGenImage image $ \img -> {#call wrapGet32F2D#} img y x

-- #define UGETC(img,color,x,y) (((uint8_t *)((img)->imageData + (y)*(img)->widthStep))[(x)*3+(color)])
instance GetPixel (Image RGB D32) where
    type P (Image RGB D32) = (D32,D32,D32)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

getPixelOldRGB (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

-- | Perform (a destructive) inplace map of the image. This should be wrapped inside
-- withClone or an image operation
mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32))
            -> Image GrayScale D32
            -> IO ()
mapImageInplace f image = withGenImage image $ \c_i -> do
             d <- {#get IplImage->imageData#} c_i
             s <- {#get IplImage->widthStep#} c_i
             let (w,h) = getSize image
                 cs = fromIntegral s
                 fs = sizeOf (undefined :: Float)
             forM_ [(x,y) | x<-[0..w-1], y <- [0..h-1]] $ \(x,y) -> do
                   v <- peek (castPtr (d `plusPtr` (y*cs+x*fs)))
                   poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v)

instance  GetPixel (Image RGB D8) where
    type P (Image RGB D8) = (D8,D8,D8)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: D8)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

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

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

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

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

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

empty :: (CreateImage (Image a b)) => (Int,Int) -> (Image a b)
empty size = unsafePerformIO $ create size

emptyCopy :: (CreateImage (Image a b)) => Image a b -> IO (Image a b)
emptyCopy img = create (getSize img)

emptyCopy' :: (CreateImage (Image a b)) => Image a b -> (Image a b)
emptyCopy' img = unsafePerformIO $ create (getSize img)

-- | Save image. This will convert the image to 8 bit one before saving
saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit $ unS image
                           withCString  filename $ \name  ->
                            withGenBareImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b
getArea = uncurry (*).getSize

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

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

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

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

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

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

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

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

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

withClone
  :: Image channels depth
     -> (Image channels depth -> IO ())
     -> IO (Image channels depth)
withClone img fun = do
                result <- cloneImage img
                fun result
                return result

withCloneValue
  :: Image channels depth
     -> (Image channels depth -> IO a)
     -> IO a
withCloneValue img fun = do
                result <- cloneImage img
                r <- fun result
                return r

unsafeImageTo32F :: Image c d -> Image c D32
unsafeImageTo32F img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)

unsafeImageTo8Bit :: Image cspace a -> Image cspace D8
unsafeImageTo8Bit img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)

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

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)
#c
enum ImageDepth {
     Depth32F = IPL_DEPTH_32F,
     Depth64F = IPL_DEPTH_64F,
     Depth8U  = IPL_DEPTH_8U,
     Depth8S  = IPL_DEPTH_8S,
     Depth16U  = IPL_DEPTH_16U,
     Depth16S  = IPL_DEPTH_16S,
     Depth32S  = IPL_DEPTH_32S
     };
#endc

{#enum ImageDepth {}#}

deriving instance Show ImageDepth

getImageDepth :: Image c d -> IO ImageDepth
getImageDepth i = withImage i $ \c_img -> {#get IplImage->depth #} c_img >>= return.toEnum.fromIntegral
getImageChannels i = withImage i $ \c_img -> {#get IplImage->nChannels #} c_img

getImageInfo x = do
    let s = getSize x
    d <- getImageDepth x
    c <- getImageChannels x
    return (s,d,c)

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

resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

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

-- #TODO: Replace the Int below with proper channel identifier
getChannel :: (Enum a) => a -> Image (ChannelOf a) d -> Image GrayScale d
getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI (1+fromEnum no) image
    cres <- {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

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

withROI :: (Int, Int) -> (Int, Int) -> Image c d -> (Image c d -> a) -> a
withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image -- BUG
                        resetROI image
                        return x

-- | Manipulate image pixels. This is slow, ugly and should be avoided
--setPixel :: (CInt,CInt) -> CDouble -> Image c d -> IO ()
{-#INLINE setPixelOld#-}
setPixelOld :: (Int,Int) -> D32 -> Image GrayScale D32 -> IO ()
setPixelOld (x,y) v image = withGenImage image $ \img ->
                          {#call wrapSet32F2D#} img (fromIntegral y) (fromIntegral x) (realToFrac v)

{-#INLINE setPixel#-}
setPixel :: (Int,Int) -> D32 -> Image GrayScale D32 -> IO ()
setPixel (x,y) v image = withGenImage image $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                              + x*sizeOf (0::Float))):: Ptr Float)
                                              v

{-#INLINE setPixel8U#-}
setPixel8U :: (Int,Int) -> Word8 -> Image GrayScale D8 -> IO ()
setPixel8U (x,y) v image = withGenImage image $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                              + x*sizeOf (0::Word8))):: Ptr Word8)
                                              v

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

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

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

{-#LANGUAGE ForeignFunctionInterface, ViewPatterns,ParallelListComp, FlexibleInstances, FlexibleContexts, TypeFamilies, EmptyDataDecls, ScopedTypeVariables, StandaloneDeriving #-}
#include "cvWrapLEO.h"
module CV.Image where

import System.Posix.Files
import System.Mem

import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Utils
import Foreign.ForeignPtr hiding (newForeignPtr)
import Foreign.Concurrent
import Foreign.Ptr
import Control.Parallel.Strategies
import Control.DeepSeq

-- import C2HSTools

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

-- Colorspaces
data GrayScale
data RGB
data RGB_Channel = Red | Green | Blue deriving (Eq,Ord,Enum)
data RGBA
data LAB
data LAB_Channel = LAB_L | LAB_A | LAB_B deriving (Eq,Ord,Enum)
type family ChannelOf a :: *
type instance ChannelOf RGB_Channel = RGB
type instance ChannelOf LAB_Channel = LAB

-- Bit Depths
type D8  = Word8
type D32 = Float
type D64 = Double

newtype Image channels depth = S BareImage

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

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

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

withGenImage = withUniPtr withImage
withGenBareImage = withUniPtr withBareImage

{#pointer *IplImage as BareImage foreign newtype#}

freeBareImage ptr = with ptr {#call cvReleaseImage#}

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

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

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

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

unImage (S (BareImage fptr)) = fptr

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

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

-- Load Image as grayscale image.

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

class Loadable a where
    readFromFile :: FilePath -> IO a

instance Loadable ((Image GrayScale D32)) where
    readFromFile fp = do
        e <- loadImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

instance Loadable ((Image RGB D32)) where
    readFromFile fp = do
        e <- loadColorImage fp
        case e of
         Just i -> return i
         Nothing -> fail $ "Could not load "++fp

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

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

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

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

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

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

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

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

class GetPixel a where
    type P a :: *
    getPixel   :: (Int,Int) -> a -> P a

-- #define FGET(img,x,y) (((float *)((img)->imageData + (y)*(img)->widthStep))[(x)])
instance GetPixel (Image GrayScale D32) where
    type P (Image GrayScale D32) = D32
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         peek (castPtr (d`plusPtr` (y*(fromIntegral s) +x*sizeOf (0::Float))):: Ptr Float)

{-#INLINE getPixelOld#-}
getPixelOld (fromIntegral -> x, fromIntegral -> y) image = realToFrac $ unsafePerformIO $
         withGenImage image $ \img -> {#call wrapGet32F2D#} img y x

-- #define UGETC(img,color,x,y) (((uint8_t *)((img)->imageData + (y)*(img)->widthStep))[(x)*3+(color)])
instance GetPixel (Image RGB D32) where
    type P (Image RGB D32) = (D32,D32,D32)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: Float)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

getPixelOldRGB (fromIntegral -> x, fromIntegral -> y) image
        = unsafePerformIO $ do
                     withGenImage image $ \img -> do
                              r <- {#call wrapGet32F2DC#} img y x 0
                              g <- {#call wrapGet32F2DC#} img y x 1
                              b <- {#call wrapGet32F2DC#} img y x 2
                              return (realToFrac r,realToFrac g, realToFrac b)

-- | Perform (a destructive) inplace map of the image. This should be wrapped inside
-- withClone or an image operation
mapImageInplace :: (P (Image GrayScale D32) -> P (Image GrayScale D32))
            -> Image GrayScale D32
            -> IO ()
mapImageInplace f image = withGenImage image $ \c_i -> do
             d <- {#get IplImage->imageData#} c_i
             s <- {#get IplImage->widthStep#} c_i
             let (w,h) = getSize image
                 cs = fromIntegral s
                 fs = sizeOf (undefined :: Float)
             forM_ [(x,y) | x<-[0..w-1], y <- [0..h-1]] $ \(x,y) -> do
                   v <- peek (castPtr (d `plusPtr` (y*cs+x*fs)))
                   poke (castPtr (d `plusPtr` (y*cs+x*fs))) (f v)

instance  GetPixel (Image RGB D8) where
    type P (Image RGB D8) = (D8,D8,D8)
    {-#INLINE getPixel#-}
    getPixel (x,y) i = unsafePerformIO $
                        withGenImage i $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         let cs = fromIntegral s
                                             fs = sizeOf (undefined :: D8)
                                         r <- peek (castPtr (d`plusPtr` (y*cs +x*3*fs)))
                                         g <- peek (castPtr (d`plusPtr` (y*cs +(x*3+1)*fs)))
                                         b <- peek (castPtr (d`plusPtr` (y*cs +(x*3+2)*fs)))
                                         return (r,g,b)

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

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

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

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

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

empty :: (CreateImage (Image a b)) => (Int,Int) -> (Image a b)
empty size = unsafePerformIO $ create size

emptyCopy :: (CreateImage (Image a b)) => Image a b -> IO (Image a b)
emptyCopy img = create (getSize img)

emptyCopy' :: (CreateImage (Image a b)) => Image a b -> (Image a b)
emptyCopy' img = unsafePerformIO $ create (getSize img)

-- | Save image. This will convert the image to 8 bit one before saving
saveImage :: FilePath -> Image c d -> IO ()
saveImage filename image = do
                           fpi <- imageTo8Bit $ unS image
                           withCString  filename $ \name  ->
                            withGenBareImage fpi    $ \cvArr ->
							 alloca (\defs -> poke defs 0 >> {#call cvSaveImage #} name cvArr defs >> return ())

getArea :: (Sized a,Num b, Size a ~ (b,b)) => a -> b
getArea = uncurry (*).getSize

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

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

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

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

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

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

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

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

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

withClone
  :: Image channels depth
     -> (Image channels depth -> IO ())
     -> IO (Image channels depth)
withClone img fun = do
                result <- cloneImage img
                fun result
                return result

withCloneValue
  :: Image channels depth
     -> (Image channels depth -> IO a)
     -> IO a
withCloneValue img fun = do
                result <- cloneImage img
                r <- fun result
                return r

unsafeImageTo32F :: Image c d -> Image c D32
unsafeImageTo32F img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure32F #} image)

unsafeImageTo8Bit :: Image cspace a -> Image cspace D8
unsafeImageTo8Bit img = unsafePerformIO $ withGenImage img $ \image ->
                creatingImage
                 ({#call ensure8U #} image)

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

imageTo8Bit img = withGenBareImage img $ \image ->
                creatingBareImage
                 ({#call ensure8U #} image)
#c
enum ImageDepth {
     Depth32F = IPL_DEPTH_32F,
     Depth64F = IPL_DEPTH_64F,
     Depth8U  = IPL_DEPTH_8U,
     Depth8S  = IPL_DEPTH_8S,
     Depth16U  = IPL_DEPTH_16U,
     Depth16S  = IPL_DEPTH_16S,
     Depth32S  = IPL_DEPTH_32S
     };
#endc

{#enum ImageDepth {}#}

deriving instance Show ImageDepth

getImageDepth :: Image c d -> IO ImageDepth
getImageDepth i = withImage i $ \c_img -> {#get IplImage->depth #} c_img >>= return.toEnum.fromIntegral
getImageChannels i = withImage i $ \c_img -> {#get IplImage->nChannels #} c_img

getImageInfo x = do
    let s = getSize x
    d <- getImageDepth x
    c <- getImageChannels x
    return (s,d,c)

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

resetROI image = withImage image $ \i ->
                  {#call cvResetImageROI#} i

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

-- #TODO: Replace the Int below with proper channel identifier
getChannel :: (Enum a) => a -> Image (ChannelOf a) d -> Image GrayScale d
getChannel no image = unsafePerformIO $ creatingImage $ do
    let (w,h) = getSize image
    setCOI (1+fromEnum no) image
    cres <- {#call wrapCreateImage32F#} (fromIntegral w) (fromIntegral h) 1
    withGenImage image $ \cimage ->
      {#call cvCopy#} cimage (castPtr cres) (nullPtr)
    resetCOI image
    return cres

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

withROI :: (Int, Int) -> (Int, Int) -> Image c d -> (Image c d -> a) -> a
withROI pos size image op = unsafePerformIO $ do
                        setROI pos size image
                        let x = op image -- BUG
                        resetROI image
                        return x

-- | Manipulate image pixels. This is slow, ugly and should be avoided
--setPixel :: (CInt,CInt) -> CDouble -> Image c d -> IO ()
{-#INLINE setPixelOld#-}
setPixelOld :: (Int,Int) -> D32 -> Image GrayScale D32 -> IO ()
setPixelOld (x,y) v image = withGenImage image $ \img ->
                          {#call wrapSet32F2D#} img (fromIntegral y) (fromIntegral x) (realToFrac v)

{-#INLINE setPixel#-}
setPixel :: (Int,Int) -> D32 -> Image GrayScale D32 -> IO ()
setPixel (x,y) v image = withGenImage image $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                              + x*sizeOf (0::Float))):: Ptr Float)
                                              v

{-#INLINE setPixel8U#-}
setPixel8U :: (Int,Int) -> Word8 -> Image GrayScale D8 -> IO ()
setPixel8U (x,y) v image = withGenImage image $ \c_i -> do
                                         d <- {#get IplImage->imageData#} c_i
                                         s <- {#get IplImage->widthStep#} c_i
                                         poke (castPtr (d`plusPtr` (y*(fromIntegral s)
                                              + x*sizeOf (0::Word8))):: Ptr Word8)
                                              v

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

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

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


gstreamer: fix marshaling on Structure where GValues weren't initialized properly reported/fixed by Oleg Belozeorov <upwawet@gmail.com>

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Structure (
  Structure,
  structureEmpty,
  structureToString,
  structureFromString,
  structureName,
  structureHasName,
  structureGetBool,
  structureGetInt,
  structureGetFourCC,
  structureGetDouble,
  structureGetString,
  structureGetDate,
  structureGetClockTime,
  structureGetFraction,

  StructureM,
  structureCreate,
  structureModify,
  structureSetNameM,
  structureRemoveFieldM,
  structureSetBoolM,
  structureSetIntM,
  structureSetFourCCM,
  structureSetDoubleM,
  structureSetStringM,
  structureSetDateM,
  structureSetClockTimeM,
  structureSetFractionM,
  structureFixateFieldNearestIntM,
  structureFixateFieldNearestDoubleM,
  structureFixateFieldNearestFractionM,
  structureFixateFieldBoolM
  ) where

import Data.Ratio ( (%)
                  , numerator
                  , denominator )
import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.UTFString
import System.Glib.FFI
import System.Glib.GTypeConstants
{#import System.Glib.GDateTime#}
{#import System.Glib.GType#}
{#import System.Glib.GValue#}
{#import System.Glib.GValueTypes#}

{# context lib = "gstreamer" prefix = "gst" #}

structureEmpty :: String
               -> Structure
structureEmpty name =
    unsafePerformIO $
        withUTFString name {# call structure_empty_new #} >>=
            takeStructure

structureToString :: Structure
                  -> String
structureToString structure =
    unsafePerformIO $
        {# call structure_to_string #} structure >>=
            readUTFString

structureFromString :: String
                    -> (Maybe Structure, Int)
structureFromString string =
    unsafePerformIO $
        withUTFString string $ \cString ->
            alloca $ \endPtr ->
                do structure <- {# call structure_from_string #} cString endPtr >>=
                                    maybePeek takeStructure
                   end <- peek endPtr
                   offset <- {# call g_utf8_pointer_to_offset #} cString end
                   return (structure, fromIntegral offset)

structureName :: Structure
              -> String
structureName structure =
    unsafePerformIO $
        {# call structure_get_name #} structure >>=
            peekUTFString

structureHasName :: Structure
                 -> String
                 -> Bool
structureHasName structure name =
    toBool $ unsafePerformIO $
        withUTFString name $
             {# call structure_has_name #} structure

marshalStructureGet :: Storable a
                    => (Structure -> CString -> Ptr a -> IO {# type gboolean #})
                    -> (a -> IO b)
                    -> Structure
                    -> String
                    -> Maybe b
marshalStructureGet getAction convert structure fieldname =
    unsafePerformIO $
        alloca $ \ptr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- getAction structure cFieldname ptr
                   if toBool result
                       then liftM Just $ peek (castPtr ptr) >>= convert
                       else return Nothing

structureGetBool :: Structure
                 -> String
                 -> Maybe Bool
structureGetBool =
    marshalStructureGet {# call structure_get_boolean #} $
        return . toBool

structureGetInt :: Structure
                -> String
                -> Maybe Int
structureGetInt =
    marshalStructureGet {# call structure_get_int #} $
        return . fromIntegral

structureGetFourCC :: Structure
                   -> String
                   -> Maybe FourCC
structureGetFourCC =
    marshalStructureGet {# call structure_get_fourcc #} $
        return . fromIntegral

structureGetDouble :: Structure
                   -> String
                   -> Maybe Double
structureGetDouble =
    marshalStructureGet {# call structure_get_double #} $
        return . realToFrac

structureGetString :: Structure
                   -> String
                   -> Maybe String
structureGetString structure fieldname =
    unsafePerformIO $
        (withUTFString fieldname $ {# call structure_get_string #} structure) >>=
            maybePeek peekUTFString

structureGetDate :: Structure
                 -> String
                 -> Maybe GDate
structureGetDate =
    marshalStructureGet {# call structure_get_date #} $
        peek . castPtr

structureGetClockTime :: Structure
                      -> String
                      -> Maybe ClockTime
structureGetClockTime =
    marshalStructureGet {# call structure_get_clock_time #} $
        return . fromIntegral

structureGetFraction :: Structure
                     -> String
                     -> Maybe Fraction
structureGetFraction structure fieldname =
    unsafePerformIO $
        alloca $ \numPtr -> alloca $ \denPtr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- {# call structure_get_fraction #} structure cFieldname numPtr denPtr
                   if toBool result
                       then do num <- peek numPtr
                               den <- peek denPtr
                               return $ Just $ (fromIntegral num) % (fromIntegral den)
                       else return Nothing

marshalStructureModify :: IO (Ptr Structure)
                       -> StructureM a
                       -> (Structure, a)
marshalStructureModify mkStructure (StructureM action) =
    unsafePerformIO $
        do ptr <- mkStructure
           structure <- liftM Structure $ newForeignPtr_ ptr
           result <- action structure
           structure' <- takeStructure ptr
           return (structure', result)

structureCreate :: String
                -> StructureM a
                -> (Structure, a)
structureCreate name action =
    marshalStructureModify
        (withUTFString name {# call structure_empty_new #})
        action

structureModify :: Structure
                -> StructureM a
                -> (Structure, a)
structureModify structure action =
    marshalStructureModify
        ({# call structure_copy #} structure)
        action

structureSetNameM :: String
                  -> StructureM ()
structureSetNameM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_set_name #} structure

structureRemoveFieldM :: String
                      -> StructureM ()
structureRemoveFieldM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_remove_field #} structure

marshalStructureSetM :: GType
                     -> (GValue -> a -> IO ())
                     -> String
                     -> a
                     -> StructureM ()
marshalStructureSetM valueType setGValue fieldname value =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
        allocaGValue $ \gValue ->
            do valueInit gValue valueType
               setGValue gValue value
               {# call structure_set_value #} structure cFieldname gValue

structureSetBoolM :: String
                  -> Bool
                  -> StructureM ()
structureSetBoolM =
    marshalStructureSetM bool valueSetBool

structureSetIntM :: String
                 -> Int
                 -> StructureM ()
structureSetIntM =
    marshalStructureSetM int valueSetInt

structureSetFourCCM :: String
                    -> FourCC
                    -> StructureM ()
structureSetFourCCM =
    marshalStructureSetM fourcc $ \gValue fourcc ->
        {# call value_set_fourcc #} gValue $ fromIntegral fourcc

structureSetDoubleM :: String
                    -> Double
                    -> StructureM ()
structureSetDoubleM =
    marshalStructureSetM double valueSetDouble

structureSetStringM :: String
                    -> String
                    -> StructureM ()
structureSetStringM =
    marshalStructureSetM string valueSetString

structureSetDateM :: String
                  -> GDate
                  -> StructureM ()
structureSetDateM =
    marshalStructureSetM date $ \gValue date ->
        with date $ ({# call value_set_date #} gValue) . castPtr

structureSetClockTimeM :: String
                       -> ClockTime
                       -> StructureM ()
structureSetClockTimeM =
    marshalStructureSetM uint64 $ \gValue clockTime ->
        {# call g_value_set_uint64 #} gValue $ fromIntegral clockTime

structureSetFractionM :: String
                      -> Fraction
                      -> StructureM ()
structureSetFractionM =
    marshalStructureSetM fraction $ \gValue fraction ->
        {# call value_set_fraction #} gValue
                                      (fromIntegral $ numerator fraction)
                                      (fromIntegral $ denominator fraction)

marshalStructureFixateM :: (Structure -> CString -> a -> IO {# type gboolean #})
                        -> String
                        -> a
                        -> StructureM Bool
marshalStructureFixateM fixate fieldname target =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
            liftM toBool $
                fixate structure cFieldname target

structureFixateFieldNearestIntM :: String
                                -> Int
                                -> StructureM Bool
structureFixateFieldNearestIntM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_int #}
            structure
            cFieldname
            (fromIntegral target)

structureFixateFieldNearestDoubleM :: String
                                   -> Double
                                   -> StructureM Bool
structureFixateFieldNearestDoubleM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_double #}
            structure
            cFieldname
            (realToFrac target)

structureFixateFieldNearestFractionM :: String
                                     -> Fraction
                                     -> StructureM Bool
structureFixateFieldNearestFractionM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_nearest_fraction #}
                    structure
                    cFieldname
                    (fromIntegral $ numerator target)
                    (fromIntegral $ denominator target)

structureFixateFieldBoolM :: String
                          -> Bool
                          -> StructureM Bool
structureFixateFieldBoolM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_boolean #}
                    structure
                    cFieldname
                    (fromBool target)

fourcc = {# call fun fourcc_get_type #}
date = {# call fun date_get_type #}
fraction = {# call fun fraction_get_type #}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gstreamer -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 1-Apr-2007
--
--  Copyright (c) 2007 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GStreamer, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GStreamer documentation.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module Media.Streaming.GStreamer.Core.Structure (
  Structure,
  structureEmpty,
  structureToString,
  structureFromString,
  structureName,
  structureHasName,
  structureGetBool,
  structureGetInt,
  structureGetFourCC,
  structureGetDouble,
  structureGetString,
  structureGetDate,
  structureGetClockTime,
  structureGetFraction,

  StructureM,
  structureCreate,
  structureModify,
  structureSetNameM,
  structureRemoveFieldM,
  structureSetBoolM,
  structureSetIntM,
  structureSetFourCCM,
  structureSetDoubleM,
  structureSetStringM,
  structureSetDateM,
  structureSetClockTimeM,
  structureSetFractionM,
  structureFixateFieldNearestIntM,
  structureFixateFieldNearestDoubleM,
  structureFixateFieldNearestFractionM,
  structureFixateFieldBoolM
  ) where

import Data.Ratio ( (%)
                  , numerator
                  , denominator )
import Control.Monad (liftM)
{#import Media.Streaming.GStreamer.Core.Types#}
import System.Glib.UTFString
import System.Glib.FFI
{#import System.Glib.GDateTime#}
{#import System.Glib.GValue#}
{#import System.Glib.GValueTypes#}

{# context lib = "gstreamer" prefix = "gst" #}

structureEmpty :: String
               -> Structure
structureEmpty name =
    unsafePerformIO $
        withUTFString name {# call structure_empty_new #} >>=
            takeStructure

structureToString :: Structure
                  -> String
structureToString structure =
    unsafePerformIO $
        {# call structure_to_string #} structure >>=
            readUTFString

structureFromString :: String
                    -> (Maybe Structure, Int)
structureFromString string =
    unsafePerformIO $
        withUTFString string $ \cString ->
            alloca $ \endPtr ->
                do structure <- {# call structure_from_string #} cString endPtr >>=
                                    maybePeek takeStructure
                   end <- peek endPtr
                   offset <- {# call g_utf8_pointer_to_offset #} cString end
                   return (structure, fromIntegral offset)

structureName :: Structure
              -> String
structureName structure =
    unsafePerformIO $
        {# call structure_get_name #} structure >>=
            peekUTFString

structureHasName :: Structure
                 -> String
                 -> Bool
structureHasName structure name =
    toBool $ unsafePerformIO $
        withUTFString name $
             {# call structure_has_name #} structure

marshalStructureGet :: Storable a
                    => (Structure -> CString -> Ptr a -> IO {# type gboolean #})
                    -> (a -> IO b)
                    -> Structure
                    -> String
                    -> Maybe b
marshalStructureGet getAction convert structure fieldname =
    unsafePerformIO $
        alloca $ \ptr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- getAction structure cFieldname ptr
                   if toBool result
                       then liftM Just $ peek (castPtr ptr) >>= convert
                       else return Nothing

structureGetBool :: Structure
                 -> String
                 -> Maybe Bool
structureGetBool =
    marshalStructureGet {# call structure_get_boolean #} $
        return . toBool

structureGetInt :: Structure
                -> String
                -> Maybe Int
structureGetInt =
    marshalStructureGet {# call structure_get_int #} $
        return . fromIntegral

structureGetFourCC :: Structure
                   -> String
                   -> Maybe FourCC
structureGetFourCC =
    marshalStructureGet {# call structure_get_fourcc #} $
        return . fromIntegral

structureGetDouble :: Structure
                   -> String
                   -> Maybe Double
structureGetDouble =
    marshalStructureGet {# call structure_get_double #} $
        return . realToFrac

structureGetString :: Structure
                   -> String
                   -> Maybe String
structureGetString structure fieldname =
    unsafePerformIO $
        (withUTFString fieldname $ {# call structure_get_string #} structure) >>=
            maybePeek peekUTFString

structureGetDate :: Structure
                 -> String
                 -> Maybe GDate
structureGetDate =
    marshalStructureGet {# call structure_get_date #} $
        peek . castPtr

structureGetClockTime :: Structure
                      -> String
                      -> Maybe ClockTime
structureGetClockTime =
    marshalStructureGet {# call structure_get_clock_time #} $
        return . fromIntegral

structureGetFraction :: Structure
                     -> String
                     -> Maybe Fraction
structureGetFraction structure fieldname =
    unsafePerformIO $
        alloca $ \numPtr -> alloca $ \denPtr ->
            withUTFString fieldname $ \cFieldname ->
                do result <- {# call structure_get_fraction #} structure cFieldname numPtr denPtr
                   if toBool result
                       then do num <- peek numPtr
                               den <- peek denPtr
                               return $ Just $ (fromIntegral num) % (fromIntegral den)
                       else return Nothing

marshalStructureModify :: IO (Ptr Structure)
                       -> StructureM a
                       -> (Structure, a)
marshalStructureModify mkStructure (StructureM action) =
    unsafePerformIO $
        do ptr <- mkStructure
           structure <- liftM Structure $ newForeignPtr_ ptr
           result <- action structure
           structure' <- takeStructure ptr
           return (structure', result)

structureCreate :: String
                -> StructureM a
                -> (Structure, a)
structureCreate name action =
    marshalStructureModify
        (withUTFString name {# call structure_empty_new #})
        action

structureModify :: Structure
                -> StructureM a
                -> (Structure, a)
structureModify structure action =
    marshalStructureModify
        ({# call structure_copy #} structure)
        action

structureSetNameM :: String
                  -> StructureM ()
structureSetNameM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_set_name #} structure

structureRemoveFieldM :: String
                      -> StructureM ()
structureRemoveFieldM name =
    StructureM $ \structure ->
        withUTFString name $ {# call structure_remove_field #} structure

marshalStructureSetM :: (GValue -> a -> IO ())
                     -> String
                     -> a
                     -> StructureM ()
marshalStructureSetM setGValue fieldname value =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
        allocaGValue $ \gValue ->
            do setGValue gValue value
               {# call structure_set_value #} structure cFieldname gValue

structureSetBoolM :: String
                  -> Bool
                  -> StructureM ()
structureSetBoolM =
    marshalStructureSetM valueSetBool

structureSetIntM :: String
                 -> Int
                 -> StructureM ()
structureSetIntM =
    marshalStructureSetM valueSetInt

structureSetFourCCM :: String
                    -> FourCC
                    -> StructureM ()
structureSetFourCCM =
    marshalStructureSetM $ \gValue fourcc ->
        {# call value_set_fourcc #} gValue $ fromIntegral fourcc

structureSetDoubleM :: String
                    -> Double
                    -> StructureM ()
structureSetDoubleM =
    marshalStructureSetM valueSetDouble

structureSetStringM :: String
                    -> String
                    -> StructureM ()
structureSetStringM =
    marshalStructureSetM valueSetString

structureSetDateM :: String
                  -> GDate
                  -> StructureM ()
structureSetDateM =
    marshalStructureSetM $ \gValue date ->
        with date $ ({# call value_set_date #} gValue) . castPtr

structureSetClockTimeM :: String
                       -> ClockTime
                       -> StructureM ()
structureSetClockTimeM =
    marshalStructureSetM $ \gValue clockTime ->
        {# call g_value_set_uint64 #} gValue $ fromIntegral clockTime

structureSetFractionM :: String
                      -> Fraction
                      -> StructureM ()
structureSetFractionM =
    marshalStructureSetM $ \gValue fraction ->
        {# call value_set_fraction #} gValue
                                      (fromIntegral $ numerator fraction)
                                      (fromIntegral $ denominator fraction)

marshalStructureFixateM :: (Structure -> CString -> a -> IO {# type gboolean #})
                        -> String
                        -> a
                        -> StructureM Bool
marshalStructureFixateM fixate fieldname target =
    StructureM $ \structure ->
        withUTFString fieldname $ \cFieldname ->
            liftM toBool $
                fixate structure cFieldname target

structureFixateFieldNearestIntM :: String
                                -> Int
                                -> StructureM Bool
structureFixateFieldNearestIntM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_int #}
            structure
            cFieldname
            (fromIntegral target)

structureFixateFieldNearestDoubleM :: String
                                   -> Double
                                   -> StructureM Bool
structureFixateFieldNearestDoubleM =
    marshalStructureFixateM $ \structure cFieldname target ->
        {# call structure_fixate_field_nearest_double #}
            structure
            cFieldname
            (realToFrac target)

structureFixateFieldNearestFractionM :: String
                                     -> Fraction
                                     -> StructureM Bool
structureFixateFieldNearestFractionM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_nearest_fraction #}
                    structure
                    cFieldname
                    (fromIntegral $ numerator target)
                    (fromIntegral $ denominator target)

structureFixateFieldBoolM :: String
                          -> Bool
                          -> StructureM Bool
structureFixateFieldBoolM =
    marshalStructureFixateM $ \structure cFieldname target ->
                {# call structure_fixate_field_boolean #}
                    structure
                    cFieldname
                    (fromBool target)


[project @ 2002-07-12 13:09:23 by dg22] Fixed references that used the old names for packing widgets.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/12 13:09:23 $
--
--  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@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackGrow else
             (if expand then PackRepel else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackGrow)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Notebook@
--
--  Author : Axel Simon
--
--  Created: 15 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@ --------------------------------------------------------------
--
-- * This widget can display several pages of widgets. Each page can be
--   selected by a tab at the top of the widget. It is useful in dialogs where
--   a lot of information has to be displayed.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
-- * check if it is sensible and possible to have something else than a Label
--   widget in the context menu. If so, change the notebook*PageMenu function
--   and add notebookSetMenuLabel and notebookSetMenuText.
--
-- * notebookSetTabLabelText is not bound.
--
-- * The signals focus-tab and select-page are not bound because it is unclear
--   what they mean. As far as I can see they are not emitted anywhere.
--
module Notebook(
  Notebook,
  NotebookClass,
  castToNotebook,
  notebookNew,
  notebookAppendPage,
  notebookAppendPageMenu,
  notebookPrependPage,
  notebookPrependPageMenu,
  notebookInsertPage,
  notebookInsertPageMenu,
  notebookRemovePage,
  notebookPageNum,
  notebookSetCurrentPage,
  notebookNextPage,
  notebookPrevPage,
  notebookReorderChild,
  PositionType(..),
  notebookSetTabPos,
  notebookSetShowTabs,
  notebookSetShowBorder,
  notebookSetScrollable,
  notebookSetTabBorder,
  notebookSetTabHBorder,
  notebookSetTabVBorder,
  notebookSetPopup,
  notebookGetCurrentPage,
  notebookGetMenuLabel,
  notebookGetNthPage,
  notebookGetTabLabel,
  Packing(..), PackType(..),
  notebookQueryTabLabelPacking,
  notebookSetTabLabelPacking,
  notebookSetHomogeneousTabs,
  notebookSetTabLabel,
  onSwitchPage,
  afterSwitchPage
  ) where

import Monad	(liftM)
import Maybe	(maybe)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Label	(labelNew)
import Enums	(Packing(..), PackType(..), PositionType(..))

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

-- methods

-- @constructor notebookNew@ Create a new notebook.
--
notebookNew :: IO Notebook
notebookNew  = makeNewObject mkNotebook $
  liftM castPtr {#call unsafe notebook_new#}

-- @method notebookAppendPage@ Insert a new tab to the right of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookAppendPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookAppendPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> IO ()
notebookAppendPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_append_page#} (toNotebook nb) (toWidget child)
    (toWidget tab)

-- @method notebookAppendPageMenu@ Insert a new tab to the right of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookAppendPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookAppendPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_append_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookPrependPage@ Insert a new tab to the left of the existing
-- tabs.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookPrependPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookPrependPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                       String -> IO ()
notebookPrependPage nb child tabLabel = do
  tab <- labelNew (Just tabLabel)
  {#call notebook_prepend_page#} (toNotebook nb) (toWidget child) (toWidget tab)

-- @method notebookPrependPageMenu@ Insert a new tab to the left of the
-- existing tabs. @ref arg menuLabel@ is the label for the context menu
-- (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookPrependPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> IO ()
notebookPrependPageMenu nb child tabWidget menuLabel = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_prepend_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu)

-- @method notebookInsertPage@ Insert a new tab at the specified position.
--
-- * The @ref arg tabName@ will be inserted as a Label widget. In case the
--   context menu is enabled, this name will appear in the menu. If you want
--   to specify something else to go in the tab, use
--   @ref method notebookInsertPageMenu@ and specify some suitable widget for
--   @ref arg menuLabel@.
--
notebookInsertPage :: (NotebookClass nb, WidgetClass child) => nb -> child ->
                      String -> Int -> IO ()
notebookInsertPage nb child tabLabel pos = do
  lbl <- labelNew (Just tabLabel)
  {#call notebook_insert_page#} (toNotebook nb) (toWidget child)
     (toWidget lbl) (fromIntegral pos)

-- @method notebookInsertPageMenu@ Insert a new tab between the tab no.
-- @ref arg pos@ and @ref arg pos@+1. @ref arg menuLabel@ is the label for the
-- context menu (useful if @ref arg tabLabel@ is not a Label widget).
--
notebookInsertPageMenu ::(NotebookClass nb, WidgetClass child,
   WidgetClass tab) => nb -> child -> tab -> String -> Int -> IO ()
notebookInsertPageMenu nb child tabWidget menuLabel pos = do
  menu <- labelNew (Just menuLabel)
  {#call notebook_insert_page_menu#} (toNotebook nb) (toWidget child)
    (toWidget tabWidget) (toWidget menu) (fromIntegral pos)

-- @method notebookRemovePage@ Remove a specific page from the notebook,
-- counting from 0.
--
notebookRemovePage :: NotebookClass nb => nb -> Int -> IO ()
notebookRemovePage nb pos =
  {#call notebook_remove_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookPageNum@ Query the page the @ref arg child@ widget is
-- contained in.
--
-- * The function returns the page number if the child was found, Nothing
--   otherwise.
--
notebookPageNum :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                   IO (Maybe Int)
notebookPageNum nb child =
  liftM (\page -> if page==(-1) then Nothing else Just (fromIntegral page)) $
  {#call unsafe notebook_page_num#} (toNotebook nb) (toWidget child)

-- @method notebookSetCurrentPage@ Move to the specified page of the notebook.
--
-- * If @ref arg pos@ is out of range (e.g. negative) select the last page.
--
notebookSetCurrentPage :: NotebookClass nb => nb -> Int -> IO ()
notebookSetCurrentPage nb pos =
  {#call notebook_set_current_page#} (toNotebook nb) (fromIntegral pos)

-- @method notebookNextPage@ Move to the right neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookNextPage :: NotebookClass nb => nb -> IO ()
notebookNextPage nb = {#call notebook_next_page#} (toNotebook nb)

-- @method notebookPrevPage@ Move to the left neighbour of the current page.
--
-- * Nothing happens if there is no such page.
--
notebookPrevPage :: NotebookClass nb => nb -> IO ()
notebookPrevPage nb = {#call notebook_prev_page#} (toNotebook nb)

-- @method notebookReorderChild@ Move a page withing the notebook.
--
notebookReorderChild :: (NotebookClass nb, WidgetClass w) => nb -> w -> Int ->
                        IO ()
notebookReorderChild nb child pos = {#call notebook_reorder_child#}
  (toNotebook nb) (toWidget child) (fromIntegral pos)

-- @method notebookSetTabPos@ Specify at which border the tabs should be
-- drawn.
--
notebookSetTabPos :: NotebookClass nb => nb -> PositionType -> IO ()
notebookSetTabPos nb pt = {#call notebook_set_tab_pos#}
  (toNotebook nb) ((fromIntegral.fromEnum) pt)

-- @method notebookSetShowTabs@ Show or hide the tabs of a notebook.
--
notebookSetShowTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowTabs nb showTabs = {#call notebook_set_show_tabs#}
  (toNotebook nb) (fromBool showTabs)

-- @method notebookSetShowBorder@ In case the tabs are not shown, specify
-- whether to draw a border around the notebook.
--
notebookSetShowBorder :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetShowBorder nb showBorder = {#call notebook_set_show_border#}
  (toNotebook nb) (fromBool showBorder)

-- @method notebookSetScrollable@ Set whether scroll bars will be added in
-- case the notebook has too many tabs to fit the widget size.
--
notebookSetScrollable :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetScrollable nb scrollable = {#call unsafe notebook_set_scrollable#}
  (toNotebook nb) (fromBool scrollable)

-- @method notebookSetTabBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets both vertical and horizontal widths.
--
notebookSetTabBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabBorder nb width = {#call notebook_set_tab_border#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabHBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets horizontal widths.
--
notebookSetTabHBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabHBorder nb width = {#call notebook_set_tab_hborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetTabVBorder@ Set the width of the borders of the tab
-- labels.
--
-- * Sets vertical widths.
--
notebookSetTabVBorder :: NotebookClass nb => nb -> Int -> IO ()
notebookSetTabVBorder nb width = {#call notebook_set_tab_vborder#}
  (toNotebook nb) (fromIntegral width)

-- @method notebookSetPopup@ Enable or disable context menus with all tabs in
-- it.
--
notebookSetPopup :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetPopup nb enable = (if enable
  then {#call notebook_popup_enable#} else {#call notebook_popup_disable#})
  (toNotebook nb)

-- @method notebookGetCurrentPage@ Query the currently selected page.
--
-- * Returns -1 if notebook has no pages.
--
notebookGetCurrentPage :: NotebookClass nb => nb -> IO Int
notebookGetCurrentPage nb = liftM fromIntegral $
  {#call unsafe notebook_get_current_page#} (toNotebook nb)

-- @method notebookGetMenuLabel@ Extract the menu label from the given
-- @ref arg child@.
--
-- * Returns Nothing if @ref arg child@ was not found.
--
notebookGetMenuLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                        IO (Maybe Label)
notebookGetMenuLabel nb child = do
  wPtr <- {#call unsafe notebook_get_menu_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookGetNthPage@ Retrieve the child widget at positon
-- @ref arg pos@ (stating from 0).
--
-- * Returns Nothing if the index is out of bounds.
--
notebookGetNthPage :: NotebookClass nb => nb -> Int -> IO (Maybe Widget)
notebookGetNthPage nb pos = do
  wPtr <- {#call unsafe notebook_get_nth_page#}
    (toNotebook nb) (fromIntegral pos)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkWidget $ return wPtr

-- @method notebookGetTabLabel@ Extract the tab label from the given
-- @ref arg child@.
--
notebookGetTabLabel :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                       IO (Maybe Label)
notebookGetTabLabel nb child = do
  wPtr <- {#call unsafe notebook_get_tab_label#}
    (toNotebook nb) (toWidget child)
  if wPtr==nullPtr then return Nothing else liftM Just $
    makeNewObject mkLabel $ return $ castPtr wPtr

-- @method notebookQueryTabLabelPacking@ Query the packing attributes of the
-- given @ref arg child@.
--
notebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                                IO (Packing,PackType)
notebookQueryTabLabelPacking nb child =
  alloca $ \expPtr -> alloca $ \fillPtr -> alloca $ \packPtr -> do
    {#call unsafe notebook_query_tab_label_packing#} (toNotebook nb)
      (toWidget child) expPtr fillPtr packPtr
    expand <- liftM toBool $ peek expPtr
    fill <- liftM toBool $ peek fillPtr
    pt <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackFill else
             (if expand then PackExpand else PackNatural),
	    pt)

-- @method notebookSetTabLabelPacking@ Set the packing attributes of the given
-- @ref arg child@.
--
notebookSetTabLabelPacking :: (NotebookClass nb, WidgetClass w) => nb -> w ->
                              Packing -> PackType -> IO ()
notebookSetTabLabelPacking nb child pack pt =
  {#call notebook_set_tab_label_packing#} (toNotebook nb) (toWidget child)
    (fromBool $ pack/=PackNatural) (fromBool $ pack==PackFill)
    ((fromIntegral.fromEnum) pt)

-- @method notebookSetHomogeneousTabs@ Sets whether the tabs must have all the
-- same size or not.
--
notebookSetHomogeneousTabs :: NotebookClass nb => nb -> Bool -> IO ()
notebookSetHomogeneousTabs nb hom = {#call notebook_set_homogeneous_tabs#}
  (toNotebook nb) (fromBool hom)

-- @method notebookSetTabLabel@ Set a new tab label for a given
-- @ref arg child@.
--
notebookSetTabLabel :: (NotebookClass nb, WidgetClass ch, WidgetClass tab) =>
                       nb -> ch -> tab -> IO ()
notebookSetTabLabel nb child tab = {#call notebook_set_tab_label#}
  (toNotebook nb) (toWidget child) (toWidget tab)

-- signals

-- @signal connectToSwitchPage@ This signal is emitted when a new page is
-- selected.
--
onSwitchPage, afterSwitchPage :: NotebookClass nb => nb -> (Int -> IO ()) ->
                                 IO (ConnectId nb)
onSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
		      (const $ return ()) False nb
		      (\_ page -> fun (fromIntegral page))
afterSwitchPage nb fun = connect_BOXED_WORD__NONE "switch-page"
			 (const $ return ()) True nb
			 (\_ page -> fun (fromIntegral page))