{-# LINE 1 "lib/CPython/Internal.chs" #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module CPython.Internal
(
module Foreign
, module Foreign.C
, cToBool
, cFromBool
, peekText
, peekTextW
, peekMaybeTextW
, withText
, withTextW
, withMaybeTextW
, mapWith
, unsafePerformIO
, SomeObject (..)
, Type (..)
, Dictionary (..)
, List (..)
, Tuple (..)
, Object (..)
, Concrete (..)
, withObject
, peekObject
, peekStaticObject
, stealObject
, incref
, decref
, callObjectRaw
, unsafeCast
, Exception (..)
, exceptionIf
, checkStatusCode
, checkBoolReturn
, checkIntReturn
, Mapping (..)
, SomeMapping (..)
, unsafeCastToMapping
, Sequence (..)
, SomeSequence (..)
, unsafeCastToSequence
, Iterator (..)
, SomeIterator (..)
, unsafeCastToIterator
) where
import Control.Applicative ((<$>))
import qualified Control.Exception as E
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Foreign hiding (unsafePerformIO)
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)
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
peekMaybeTextW :: CWString -> IO (Maybe T.Text)
peekMaybeTextW = maybePeek peekTextW
withText :: T.Text -> (CString -> IO a) -> IO a
withText = withCString . T.unpack
withTextW :: T.Text -> (CWString -> IO a) -> IO a
withTextW = withCWString . T.unpack
withMaybeTextW :: Maybe T.Text -> (CWString -> IO a) -> IO a
withMaybeTextW = maybeWith withTextW
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
incref :: (Ptr a) -> IO ((()))
incref a1 =
let {a1' = castPtr a1} in
incref'_ a1' >>= \res ->
let {res' = id res} in
return (res')
{-# LINE 171 "lib/CPython/Internal.chs" #-}
decref :: (Ptr a) -> IO ((()))
decref a1 =
let {a1' = castPtr a1} in
decref'_ a1' >>= \res ->
let {res' = id res} in
return (res')
{-# LINE 175 "lib/CPython/Internal.chs" #-}
foreign import ccall "hscpython-shim.h &hscpython_Py_DECREF"
staticDecref :: FunPtr (Ptr a -> IO ())
callObjectRaw :: (Object self, Object args) => (self) -> (args) -> IO ((SomeObject))
callObjectRaw a1 a2 =
withObject a1 $ \a1' ->
withObject a2 $ \a2' ->
callObjectRaw'_ a1' a2' >>= \res ->
stealObject res >>= \res' ->
return (res')
{-# LINE 184 "lib/CPython/Internal.chs" #-}
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
pyErrFetch pType pValue pTrace
pyErrNormalizeException 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
instance Object SomeMapping where
toObject (SomeMapping x) = SomeObject x
fromForeignPtr = SomeMapping
instance Mapping SomeMapping where
toMapping = id
unsafeCastToMapping :: Object a => a -> SomeMapping
unsafeCastToMapping x = case toObject x of
SomeObject ptr -> let
ptr' = castForeignPtr ptr :: ForeignPtr SomeMapping
in SomeMapping ptr'
data SomeSequence = forall a. (Sequence a) => SomeSequence (ForeignPtr a)
class Object a => Sequence a where
toSequence :: a -> SomeSequence
instance Object SomeSequence where
toObject (SomeSequence x) = SomeObject x
fromForeignPtr = SomeSequence
instance Sequence SomeSequence where
toSequence = id
unsafeCastToSequence :: Object a => a -> SomeSequence
unsafeCastToSequence x = case toObject x of
SomeObject ptr -> let
ptr' = castForeignPtr ptr :: ForeignPtr SomeSequence
in SomeSequence ptr'
data SomeIterator = forall a. (Iterator a) => SomeIterator (ForeignPtr a)
class Object a => Iterator a where
toIterator :: a -> SomeIterator
instance Object SomeIterator where
toObject (SomeIterator x) = SomeObject x
fromForeignPtr = SomeIterator
instance Iterator SomeIterator where
toIterator = id
unsafeCastToIterator :: Object a => a -> SomeIterator
unsafeCastToIterator x = case toObject x of
SomeObject ptr -> let
ptr' = castForeignPtr ptr :: ForeignPtr SomeIterator
in SomeIterator ptr'
foreign import ccall safe "CPython/Internal.chs.h hscpython_Py_INCREF"
incref'_ :: ((Ptr ()) -> (IO ()))
foreign import ccall safe "CPython/Internal.chs.h hscpython_Py_DECREF"
decref'_ :: ((Ptr ()) -> (IO ()))
foreign import ccall safe "CPython/Internal.chs.h PyObject_CallObject"
callObjectRaw'_ :: ((Ptr ()) -> ((Ptr ()) -> (IO (Ptr ()))))
foreign import ccall safe "CPython/Internal.chs.h PyErr_Fetch"
pyErrFetch :: ((Ptr (Ptr ())) -> ((Ptr (Ptr ())) -> ((Ptr (Ptr ())) -> (IO ()))))
foreign import ccall safe "CPython/Internal.chs.h PyErr_NormalizeException"
pyErrNormalizeException :: ((Ptr (Ptr ())) -> ((Ptr (Ptr ())) -> ((Ptr (Ptr ())) -> (IO ()))))