[Gtk2hs-commit] gtk2hs/glib/System/Glib GError.chs.pp,NONE,1.1 FFI.hs,NONE,1.1 GList.chs,NONE,1.1

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/glib/System/Glib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1228/glib/System/Glib

Added Files:
	GError.chs.pp FFI.hs GList.chs 
Log Message:
move glib modules to a seperate package and use hierarchical namespace names.


--- NEW FILE: FFI.hs ---
{-# OPTIONS -cpp #-}
--  GIMP Toolkit (GTK) version dependencies
--
--  Author : Axel Simon
--          
--  Created: 22 June 2001
--
--  Version $Revision: 1.1 $ from $Date: 2005/01/08 17:45:06 $
--
--  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.
--
-- |
--
-- This module serves as an impedance matcher for different compiler
-- versions.
--

module System.Glib.FFI (
  with,
  nullForeignPtr,
  foreignFree,
  newForeignPtr,
  foreignPtrToPtr,
  module Foreign,
  module Foreign.C
  ) where

import Foreign (unsafePerformIO)

import Foreign.C
import qualified Foreign
# if __GLASGOW_HASKELL__>=602
import Foreign	 hiding		(with, newForeignPtr)
import qualified Foreign hiding	(newForeignPtr)
# else
import Foreign	 hiding (with)
# endif

with :: (Storable a) => a -> (Ptr a -> IO b) -> IO b
with = Foreign.with

#if __GLASGOW_HASKELL__>=602
newForeignPtr = flip Foreign.newForeignPtr

foreignPtrToPtr = unsafeForeignPtrToPtr
#endif

#if __GLASGOW_HASKELL__>=600
foreign import ccall unsafe "&free"	--TODO: should we be using g_free?
  free' :: FinalizerPtr a

foreignFree :: Ptr a -> FinalizerPtr a
foreignFree _ = free'

nullForeignPtr :: ForeignPtr a
nullForeignPtr = unsafePerformIO $ newForeignPtr nullPtr free'
#else
nullForeignPtr :: ForeignPtr a
nullForeignPtr = unsafePerformIO $ newForeignPtr nullPtr (return ())

foreignFree :: Ptr a -> IO ()
foreignFree = free
#endif


--- NEW FILE: GList.chs ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK)
--
--  Author : Axel Simon
--          
--  Created: 19 March 2002
--
--  Version $Revision: 1.1 $ from $Date: 2005/01/08 17:45:06 $
--
--  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.
--
-- |
--
-- Defines functions to extract data from a GList and to produce a GList from
-- a list of pointers.
--
-- * The same for GSList.
--
module System.Glib.GList (
  ptrToInt,
  GList,
  fromGList,
  toGList,
  GSList,
  readGSList,
  fromGSList,
  fromGSListRev,
  toGSList
  ) where

import Monad	(liftM)
import Foreign

{# context lib="glib" prefix="g" #}

{#pointer * GList#}
{#pointer * GSList#}

-- methods

-- Convert a pointer to an Int.
--
ptrToInt :: Ptr a -> Int
ptrToInt ptr = minusPtr ptr nullPtr 

-- Turn a GList into a list of pointers.
--
fromGList :: GList -> IO [Ptr a]
fromGList glist = do
    glist' <- {#call unsafe list_reverse#} glist
    extractList glist' []
  where
    extractList gl xs
      | gl==nullPtr = return xs
      | otherwise   = do
	x <- {#get GList.data#} gl
	gl' <- {#call unsafe list_delete_link#} gl gl
	extractList gl' (castPtr x:xs)

-- Turn a GSList into a list of pointers but don't destroy the list.
--
readGSList :: GSList -> IO [Ptr a]
readGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#get GSList->next#} gslist
    xs <- readGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers.
--
fromGSList :: GSList -> IO [Ptr a]
fromGSList gslist
  | gslist==nullPtr = return []
  | otherwise	    = do
    x <- {#get GSList->data#} gslist
    gslist' <- {#call unsafe slist_delete_link#} gslist gslist
    xs <- fromGSList gslist'
    return (castPtr x:xs)

-- Turn a GSList into a list of pointers and reverse it.
--
fromGSListRev :: GSList -> IO [Ptr a]
fromGSListRev gslist =
  extractList gslist []
  where
    extractList gslist xs
      | gslist==nullPtr = return xs
      | otherwise	= do
	x <- {#get GSList->data#} gslist
	gslist' <- {#call unsafe slist_delete_link#} gslist gslist
	extractList gslist' (castPtr x:xs)

-- Convert an Int into a pointer.
--
intToPtr :: Int -> Ptr a
intToPtr int = plusPtr nullPtr int


-- Turn a list of something into a GList.
--
toGList :: [Ptr a] -> IO GList
toGList xs = makeList nullPtr xs
  where
    -- makeList :: GList -> [Ptr a] -> IO GList
    makeList current (x:xs) = do
      newHead <- {#call unsafe list_prepend#} current (castPtr x)
      makeList newHead xs
    makeList current [] = return current

-- Turn a list of something into a GSList.
--
toGSList :: [Ptr a] -> IO GSList
toGSList xs = makeList nullPtr xs
  where
    -- makeList :: GSList -> [Ptr a] -> IO GSList
    makeList current (x:xs) = do
      newHead <- {#call unsafe slist_prepend#} current (castPtr x)
      makeList newHead xs
    makeList current [] = return current


--- NEW FILE: GError.chs.pp ---
-- -*-haskell-*-
--  GIMP Toolkit (GTK) GError API
--
--  Author : Duncan Coutts
--  Created: 2 July 2004
--
--  Copyright (c) 2004 Duncan Coutts
--  parts derived from Structs.hsc Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
--  Error Reporting, glib's system for reporting errors.
--
--  'GError's are used by glib to report recoverable runtime errors.
--
--  This module provides functions for checking glib\/gtk functions that report
--  'GError's. It also provides functions for throwing and catching 'GError's as
--  Haskell exceptions.
--

module System.Glib.GError (

  -- * Data types
  --
  GError(..),
  GErrorDomain,
  GErrorCode,
  GErrorMessage,
  
  -- * Catching GError exceptions
  -- | To catch GError exceptions thrown by gtk2hs functions use the catchGError*
  --   or handleGError* functions. They work in a similar way to the standard
  --   'Control.Exception.catch' and 'Control.Exception.handle' functions.
  --
  --   'catchGError'\/'handleGError' catches all GError exceptions, you provide a
  --   handler function that gets given the GError if an exception was thrown. This
  --   is the most general but is probably not what you want most of the time. It
  --   just gives you the raw error code rather than a Haskell enumeration of the
  --   error codes. Most of the time you will only want to catch a specific error
  --   or any error from a specific error domain. To catch just a single specific
  --   error use 'catchGErrorJust'\/'handleGErrorJust'. To catch any error in a 
  --   particular error domain use 'catchGErrorJustDomain'\/'handleGErrorJustDomain'
  --
  catchGError,
  catchGErrorJust,
  catchGErrorJustDomain,
  
  handleGError,
  handleGErrorJust,
  handleGErrorJustDomain,
  
  failOnGError,
  throwGError,

  -- * Checking for GErrors returned by glib\/gtk functions
  -- | * Note, these functions are only useful to implementors
  --
  --   If you are wrapping a new API that reports 'GError's you should probably use
  --   'propagateGError' to convert the GError into an exception. You should also
  --   note in the documentation for the function that it throws GError exceptions
  --   and the Haskell enumeration for the expected glib GError domain(s), so that
  --   users know what exceptions they might want to catch.
  --
  --   If you think it is more appropriate to use an alternate return value (eg
  --   Either\/Maybe) then you should use 'checkGError' or 'checkGErrorWithCont'.

  GErrorClass(..),
  propagateGError,
  checkGError,
  checkGErrorWithCont
  
  ) where

import Monad (when)
import Foreign
import Foreign.C
import System.Glib.UTFString
import Control.Exception
import Data.Dynamic

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

-- | A GError consists of a domain, code and a human readable message.
data GError = GError !GErrorDomain !GErrorCode !GErrorMessage
# if __GLASGOW_HASKELL__>=600
  deriving Typeable
#else
{-# NOINLINE gerrorTypeRep #-}
gerrorTypeRep :: TypeRep
gerrorTypeRep = mkAppTy (mkTyCon "Graphics.UI.Gtk.GError.GError") []
instance Typeable GError where
  typeOf _ = gerrorTypeRep
#endif

type GQuark = {#type GQuark #}

-- | A code used to identify the \'namespace\' of the error. Within each error
--   domain all the error codes are defined in an enumeration. Each gtk\/gnome
--   module that uses GErrors has its own error domain. The rationale behind
--   using error domains is so that each module can organise its own error codes
--   without having to coordinate on a global error code list.
type GErrorDomain  = GQuark

-- | A code to identify a specific error within a given 'GErrorDomain'. Most of
--   time you will not need to deal with this raw code since there is an
--   enumeration type for each error domain. Of course which enumeraton to use
--   depends on the error domain, but if you use 'catchGErrorJustDomain' or
--   'handleGErrorJustDomain', this is worked out for you automatically.
type GErrorCode = Int

-- | A human readable error message.
type GErrorMessage = String
                                                                                           
instance Storable GError where
  sizeOf _ = {#sizeof GError #}
  alignment _ = alignment (undefined:: GQuark)
  peek ptr = do
    (domain  :: GQuark)         <- {#get GError->domain  #} ptr
    (code    :: {#type gint #}) <- {#get GError->code    #} ptr
    (msgPtr  :: CString)        <- {#get GError->message #} ptr
    msg <- peekUTFString msgPtr
    return $ GError (fromIntegral domain) (fromIntegral code) msg
  poke _ = error "GError::poke: not implemented"

-- | Each error domain's error enumeration type should be an instance of this
--   class. This class helps to hide the raw error and domain codes from the
--   user. This interface should be implemented by calling the approrpiate
--   @{error_domain}_error_quark@. It is safe to use 'unsafePerformIO' for this.
--
-- Example for 'PixbufError':
--
-- > instance GErrorClass PixbufError where
-- >   gerrorDomain _ = unsafePerformIO {#call unsafe pixbuf_error_quark#}
--
class Enum err => GErrorClass err where
  gerrorDomain :: err -> GErrorDomain -- ^ This must not use the value of its parameter
                                      --   so that it is safe to pass 'undefined'.

-- | Glib functions which report 'GError's take as a parameter a @GError **error@.
--   Use this function to supply such a parameter. It checks if an error was
--   reported and if so throws it as a Haskell exception.
--   
-- Example of use:
--
-- > propagateGError $ \gerrorPtr ->
-- > {# call g_some_function_that_might_return_an_error #} a b gerrorPtr
--
propagateGError :: (Ptr (Ptr ()) -> IO a) -> IO a
propagateGError action = checkGError action throwGError

-- | Like 'propagateGError' but instead of throwing the GError as an exception
--   handles the error immediately using the supplied error handler.
--
-- Example of use:
--
-- > checkGError
-- >   (\gerrorPtr -> {# call g_some_function_that_might_return_an_error #} a b gerrorPtr)
-- >   (\(GError domain code msg) -> ...)
--
checkGError :: (Ptr (Ptr ()) -> IO a) -> (GError -> IO a) -> IO a
checkGError action handler =
  alloca $ \(errPtrPtr  :: Ptr (Ptr GError)) -> do
  poke errPtrPtr nullPtr
  result <- action (castPtr errPtrPtr)
  errPtr <- peek errPtrPtr
  if errPtr == nullPtr
    then return result
    else do gerror <- peek errPtr
            {# call unsafe g_error_free #} (castPtr errPtr)
            handler gerror

-- | Like 'checkGError' but with an extra continuation applied to the result.
--   This can be useful when something needs to be done after making the call
--   to the function that can raise an error but is should only be done if there
--   was no error.
--
-- Example of use:
--
-- > checkGErrorWithCont (\gerrorPtr ->
-- >   {# call g_some_function_that_might_return_an_error #} a b gerrorPtr)
-- > (\(GError domain code msg) -> ...) -- what to do in case of error
-- > (\result -> ...)                   -- what to do after if no error
--
checkGErrorWithCont :: (Ptr (Ptr ()) -> IO b) -> (GError -> IO a) -> (b -> IO a) -> IO a
checkGErrorWithCont action handler cont =
  alloca $ \(errPtrPtr  :: Ptr (Ptr GError)) -> do
  poke errPtrPtr nullPtr
  result <- action (castPtr errPtrPtr)
  errPtr <- peek errPtrPtr
  if errPtr == nullPtr
    then cont result
    else do gerror <- peek errPtr
            {# call unsafe g_error_free #} (castPtr errPtr)
            handler gerror

-- | Use this if you need to explicitly throw a GError or re-throw an existing
--   GError that you do not wish to handle.
throwGError :: GError -> IO a
throwGError gerror = evaluate (throwDyn gerror)

-- | This will catch any GError exception. The handler function will receive the
--   raw GError. This is probably only useful when you want to take some action
--   that does not depend on which GError exception has occured, otherwise it
--   would be better to use either 'catchGErrorJust' or 'catchGErrorJustDomain'.
--   For example:
--
-- > catchGError
-- >   (do ...
-- >       ...)
-- >   (\(GError dom code msg) -> fail msg)
--   
catchGError :: IO a            -- ^ The computation to run
            -> (GError -> IO a) -- ^ Handler to invoke if an exception is raised
            -> IO a
catchGError action handler = catchDyn action handler

-- | This will catch just a specific GError exception. If you need to catch a
--   range of related errors, 'catchGErrorJustDomain' is probably more
--   appropriate. Example:
--
-- > do image <- catchGErrorJust PixbufErrorCorruptImage
-- >               loadImage
-- >               (\errorMessage -> do log errorMessage
-- >                                    return mssingImagePlaceholder)
--
catchGErrorJust :: GErrorClass err => err  -- ^ The error to catch
                -> IO a                    -- ^ The computation to run
                -> (GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                -> IO a
catchGErrorJust code action handler = catchGError action handler'
  where handler' gerror@(GError domain code' msg)
          | fromIntegral domain == gerrorDomain code
           && code' == fromEnum code   = handler msg
          | otherwise                  = throwGError gerror

-- | Catch all GErrors from a particular error domain. The handler function
--   should just deal with one error enumeration type. If you need to catch
--   errors from more than one error domain, use this function twice with an
--   appropriate handler functions for each.
--
-- > catchGErrorJustDomain
-- >   loadImage
-- >   (\err message -> case err of
-- >       PixbufErrorCorruptImage -> ...
-- >       PixbufErrorInsufficientMemory -> ...
-- >       PixbufErrorUnknownType -> ...
-- >       _ -> ...)
--
catchGErrorJustDomain :: GErrorClass err => IO a        -- ^ The computation to run
                      -> (err -> GErrorMessage -> IO a) -- ^ Handler to invoke if an exception is raised
                      -> IO a
catchGErrorJustDomain action (handler :: err -> GErrorMessage -> IO a) =
    catchGError action handler'
  where handler' gerror@(GError domain code msg)
          | fromIntegral domain == gerrorDomain (undefined::err) = handler (toEnum code) msg
          | otherwise                                            = throwGError gerror

-- | A verson of 'catchGError' with the arguments swapped around.
--
-- > handleGError (\(GError dom code msg) -> ...) $
-- >   ...
--   
handleGError :: (GError -> IO a) -> IO a -> IO a
handleGError = flip catchGError

-- | A verson of 'handleGErrorJust' with the arguments swapped around.
handleGErrorJust :: GErrorClass err => err -> (GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJust code = flip (catchGErrorJust code)

-- | A verson of 'handleGErrorJustDomain' with the arguments swapped around.
handleGErrorJustDomain :: GErrorClass err => (err -> GErrorMessage -> IO a) -> IO a -> IO a
handleGErrorJustDomain = flip catchGErrorJustDomain

-- | Catch all GError exceptions and convert them into a general failure.
failOnGError :: IO a -> IO a
failOnGError action = catchGError action (\(GError dom code msg) -> fail msg)