cpython-3.1.0: CPython/Internal.chs

-- 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/>.
-- 
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
module CPython.Internal
	(
	-- * FFI support
	  module Foreign
	, module Foreign.C
	, cToBool
	, cFromBool
	, peekText
	, peekTextW
	, withText
	, withTextW
	, mapWith
	
	-- * Fundamental types
	, SomeObject (..)
	, Type (..)
	, Dictionary (..)
	, List (..)
	, Tuple (..)
	
	-- * Objects
	, Object (..)
	, Concrete (..)
	, withObject
	, peekObject
	, peekStaticObject
	, stealObject
	, incref
	, decref
	, callObjectRaw
	, unsafeCast
	
	-- * Exceptions
	, Exception (..)
	, exceptionIf
	, checkStatusCode
	, checkBoolReturn
	, checkIntReturn
	
	-- * Other classes
	, Mapping (..)
	, SomeMapping (..)
	, Sequence (..)
	, SomeSequence (..)
	) where
import Control.Applicative ((<$>))
import qualified Control.Exception as E
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Foreign
import Foreign.C

#include <hscpython-shim.h>

cToBool :: CInt -> Bool
cToBool = (/= 0)

cFromBool :: Bool -> CInt
cFromBool x = if x then 1 else 0

peekText :: CString -> IO T.Text
peekText = fmap T.pack . peekCString

peekTextW :: CWString -> IO T.Text
peekTextW = fmap T.pack . peekCWString

withText :: T.Text -> (CString -> IO a) -> IO a
withText = withCString . T.unpack

withTextW :: T.Text -> (CWString -> IO a) -> IO a
withTextW = withCWString . T.unpack

mapWith :: (a -> (b -> IO c) -> IO c) -> [a] -> ([b] -> IO c) -> IO c
mapWith with' = step [] where
	step acc [] io = io acc
	step acc (x:xs) io = with' x $ \y -> step (acc ++ [y]) xs io

data SomeObject = forall a. (Object a) => SomeObject (ForeignPtr a)

class Object a where
	toObject :: a -> SomeObject
	fromForeignPtr :: ForeignPtr a -> a

class Object a => Concrete a where
	concreteType :: a -> Type

instance Object SomeObject where
	toObject = id
	fromForeignPtr = SomeObject

newtype Type = Type (ForeignPtr Type)
instance Object Type where
	toObject (Type x) = SomeObject x
	fromForeignPtr = Type

newtype Dictionary = Dictionary (ForeignPtr Dictionary)
instance Object Dictionary where
	toObject (Dictionary x) = SomeObject x
	fromForeignPtr = Dictionary

newtype List = List (ForeignPtr List)
instance Object List where
	toObject (List x) = SomeObject x
	fromForeignPtr = List

newtype Tuple = Tuple (ForeignPtr Tuple)
instance Object Tuple where
	toObject (Tuple x) = SomeObject x
	fromForeignPtr = Tuple

withObject :: Object obj => obj -> (Ptr a -> IO b) -> IO b
withObject obj io = case toObject obj of
	SomeObject ptr -> withForeignPtr ptr (io . castPtr)

peekObject :: Object obj => Ptr a -> IO obj
peekObject ptr = E.bracketOnError incPtr decref mkObj where
	incPtr = incref ptr >> return ptr
	mkObj _ = fromForeignPtr <$> newForeignPtr staticDecref (castPtr ptr)

peekStaticObject :: Object obj => Ptr a -> IO obj
peekStaticObject ptr = fromForeignPtr <$> newForeignPtr_ (castPtr ptr)

unsafeStealObject :: Object obj => Ptr a -> IO obj
unsafeStealObject ptr = fromForeignPtr <$> newForeignPtr staticDecref (castPtr ptr)

stealObject :: Object obj => Ptr a -> IO obj
stealObject ptr = exceptionIf (ptr == nullPtr) >> unsafeStealObject ptr

{# fun hscpython_Py_INCREF as incref
	{ castPtr `Ptr a'
	} -> `()' id #}

{# fun hscpython_Py_DECREF as decref
	{ castPtr `Ptr a'
	} -> `()' id #}

foreign import ccall "hscpython-shim.h &hscpython_Py_DECREF"
	staticDecref :: FunPtr (Ptr a -> IO ())

{# fun PyObject_CallObject as callObjectRaw
	`(Object self, Object args)' =>
	{ withObject* `self'
	, withObject* `args'
	} -> `SomeObject' stealObject* #}

unsafeCast :: (Object a, Object b) => a -> b
unsafeCast a = case toObject a of
	SomeObject ptr -> fromForeignPtr (castForeignPtr ptr)

data Exception = Exception
	{ exceptionType      :: SomeObject
	, exceptionValue     :: SomeObject
	, exceptionTraceback :: Maybe SomeObject
	}
	deriving (Typeable)

instance Show Exception where
	show _ = "<CPython exception>"

instance E.Exception Exception

exceptionIf :: Bool -> IO ()
exceptionIf False = return ()
exceptionIf True =
	alloca $ \pType ->
	alloca $ \pValue ->
	alloca $ \pTrace -> do
		{# call PyErr_Fetch as ^ #} pType pValue pTrace
		{# call PyErr_NormalizeException as ^ #} pType pValue pTrace
		eType <- unsafeStealObject =<< peek pType
		eValue <- unsafeStealObject =<< peek pValue
		eTrace <- maybePeek unsafeStealObject =<< peek pTrace
		E.throwIO $ Exception eType eValue eTrace

checkStatusCode :: CInt -> IO ()
checkStatusCode = exceptionIf . (== -1)

checkBoolReturn :: CInt -> IO Bool
checkBoolReturn x = do
	exceptionIf $ x == -1
	return $ x /= 0

checkIntReturn :: Integral a => a -> IO Integer
checkIntReturn x = do
	exceptionIf $ x == -1
	return $ toInteger x

data SomeMapping = forall a. (Mapping a) => SomeMapping (ForeignPtr a)

class Object a => Mapping a where
	toMapping :: a -> SomeMapping

data SomeSequence = forall a. (Sequence a) => SomeSequence (ForeignPtr a)

class Object a => Sequence a where
	toSequence :: a -> SomeSequence