Capsule.chs

{-# LANGUAGE ForeignFunctionInterface #-}

-- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
--
-- This program 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 3 of the License, or
-- any later version.
--
-- This program 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.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module CPython.Types.Capsule
	( Capsule
	, capsuleType
	--, new
	, getPointer
	--, getDestructor
	, getContext
	, getName
	, importNamed
	, isValid
	, setPointer
	--, setDestructor
	, setContext
	--, setName
	) where

#include <hscpython-shim.h>

import           Data.Text (Text)

import           CPython.Internal hiding (new)

-- type Destructor = Ptr () -> IO ()
newtype Capsule = Capsule (ForeignPtr Capsule)

instance Object Capsule where
	toObject (Capsule x) = SomeObject x
	fromForeignPtr = Capsule

instance Concrete Capsule where
	concreteType _ = capsuleType

{# fun pure unsafe hscpython_PyCapsule_Type as capsuleType
	{} -> `Type' peekStaticObject* #}

-- new :: Ptr () -> Maybe Text -> Destructor -> IO Capsule
-- new = undefined

-- | Retrieve the pointer stored in the capsule. On failure, throws an
-- exception.
--
-- The name parameter must compare exactly to the name stored in the capsule.
-- If the name stored in the capsule is 'Nothing', the name passed in must
-- also be 'Nothing'. Python uses the C function strcmp() to compare capsule
-- names.
getPointer :: Capsule -> Maybe Text -> IO (Ptr ())
getPointer py name =
	withObject py $ \pyPtr ->
	maybeWith withText name $ \namePtr ->
	{# call PyCapsule_GetPointer as ^ #} pyPtr namePtr

-- getDestructor :: Capsule -> IO (Maybe Destructor)
-- getDestructor = undefined

-- | Return the current context stored in the capsule, which might be @NULL@.
getContext :: Capsule -> IO (Ptr ())
getContext py =
	withObject py $ \pyPtr -> do
	{# call PyErr_Clear as ^ #}
	ptr <- {# call PyCapsule_GetContext as ^ #} pyPtr
	if ptr /= nullPtr
		then return ptr
		else do
			exc <- {# call PyErr_Occurred as ^ #}
			exceptionIf $ exc /= nullPtr
			return ptr

-- | Return the current name stored in the capsule, which might be 'Nothing'.
getName :: Capsule -> IO (Maybe Text)
getName py =
	withObject py $ \pyPtr -> do
	{# call PyErr_Clear as ^ #}
	ptr <- {# call PyCapsule_GetName as ^ #} pyPtr
	if ptr /= nullPtr
		then Just `fmap` peekText ptr
		else do
			exc <- {# call PyErr_Occurred as ^ #}
			exceptionIf $ exc /= nullPtr
			return Nothing

-- | Import a pointer to a C object from a capsule attribute in a module.
-- The name parameter should specify the full name to the attribute, as in
-- @\"module.attribute\"@. The name stored in the capsule must match this
-- string exactly. If the second parameter is 'False', import the module
-- without blocking (using @PyImport_ImportModuleNoBlock()@). Otherwise,
-- imports the module conventionally (using @PyImport_ImportModule()@).
--
-- Return the capsule&#x2019;s internal pointer on success. On failure, throw
-- an exception. If the module could not be imported, and if importing in
-- non-blocking mode, returns 'Nothing'.
importNamed :: Text -> Bool -> IO (Maybe (Ptr ()))
importNamed name block =
	withText name $ \namePtr ->
	let noBlock = cFromBool (not block) in do
	{# call PyErr_Clear as ^ #}
	ptr <- {# call PyCapsule_Import as ^ #} namePtr noBlock
	if ptr /= nullPtr
		then return $ Just ptr
		else do
			exc <- {# call PyErr_Occurred as ^ #}
			exceptionIf $ exc /= nullPtr
			return Nothing

-- | Determines whether or not a capsule is valid. A valid capsule's type is
-- 'capsuleType', has a non-NULL pointer stored in it, and its internal name
-- matches the name parameter. (See 'getPointer' for information on how
-- capsule names are compared.)
--
-- In other words, if 'isValid' returns 'True', calls to any of the
-- accessors (any function starting with @get@) are guaranteed to succeed.
isValid :: Capsule -> Maybe Text -> IO Bool
isValid py name =
	withObject py $ \pyPtr ->
	maybeWith withText name $ \namePtr ->
	{# call PyCapsule_IsValid as ^ #} pyPtr namePtr
	>>= checkBoolReturn

-- | Set the void pointer inside the capsule. The pointer may not be @NULL@.
{# fun PyCapsule_SetPointer as setPointer
	{ withObject* `Capsule'
	, id `Ptr ()'
	} -> `()' checkStatusCode* #}

-- setDestructor :: Capsule -> Maybe Destructor -> IO ()
-- setDestructor = undefined

-- | Set the context pointer inside the capsule.
{# fun PyCapsule_SetContext as setContext
	{ withObject* `Capsule'
	, id `Ptr ()'
	} -> `()' checkStatusCode* #}

-- setName :: Capsule -> Maybe Text -> IO ()
-- setName = undefined