#line 1 "src/Foreign/Java/Bindings/Support.cpphs" {-# LANGUAGE Haskell2010 , TypeFamilies , FlexibleContexts , FlexibleInstances , TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -- | -- Module : Foreign.Java.Bindings.Support -- Copyright : (c) Julian Fleischer 2013 -- License : MIT (See LICENSE file in cabal package) -- -- Maintainer : julian.fleischer@fu-berlin.de -- Stability : experimental -- Portability : non-portable (TypeFamilies) -- -- This module provides type classes and instances for -- supporting the high level bindings. This module should -- not be imported directly. module Foreign.Java.Bindings.Support where import Control.Monad.State hiding (void) import Data.Int import Data.Word import Data.Maybe import Foreign.Ptr import Foreign.ForeignPtr import Foreign.C.Types import Foreign.Java import Foreign.Java.JavaMonad import Foreign.Java.Types as T import qualified Foreign.Java.JNI.Safe as JNI import qualified Foreign.Java.JNI.Types as Core --------------- -- Utilities -- --------------- object' :: String -> Q object' = T.object' ------------------------------ -- Primitive argument types -- ------------------------------ class JBoolean a where toBoolean :: a -> Java Bool class JChar a where toChar :: a -> Java Word16 class JByte a where toByte :: a -> Java Int8 class JShort a where toShort :: a -> Java Int16 class JInt a where toInt :: a -> Java Int32 class JLong a where toLong :: a -> Java Int64 class JFloat a where toFloat :: a -> Java Float class JDouble a where toDouble :: a -> Java Double instance JBoolean Bool where toBoolean = return instance JChar Char where toChar = return . fromIntegral . fromEnum instance JChar Int8 where toChar = return . fromIntegral instance JChar Word16 where toChar = return instance JByte Int8 where toByte = return instance JShort Int8 where toShort = return . fromIntegral instance JShort Word8 where toShort = return . fromIntegral instance JShort Int16 where toShort = return instance JInt Int where toInt = return . fromIntegral instance JInt Int8 where toInt = return . fromIntegral instance JInt Word8 where toInt = return . fromIntegral instance JInt Int16 where toInt = return . fromIntegral instance JInt Word16 where toInt = return . fromIntegral instance JInt Int32 where toInt = return instance JLong Int where toLong = return . fromIntegral instance JLong Int8 where toLong = return . fromIntegral instance JLong Word8 where toLong = return . fromIntegral instance JLong Int16 where toLong = return . fromIntegral instance JLong Word16 where toLong = return . fromIntegral instance JLong Int32 where toLong = return . fromIntegral instance JLong Word32 where toLong = return . fromIntegral instance JLong Int64 where toLong = return instance JFloat CFloat where toFloat = return . realToFrac instance JFloat Float where toFloat = return instance JDouble CDouble where toDouble = return . realToFrac instance JDouble Double where toDouble = return -------------------------- -- Array argument types -- -------------------------- class Array a where asMaybeArrayObject :: a -> Java (Maybe JObject) ---------------------------- -- Primitive result types -- ---------------------------- -- | The result of a function call that is of type @boolean@. class BooleanResult m where { toBooleanResult :: Either JThrowable Bool -> Java m } ; instance BooleanResult Bool where { toBooleanResult = either (\exc -> toString exc >>= fail) return } ; instance BooleanResult (Either JThrowable Bool) where { toBooleanResult = return } -- | The result of a function call that is of type @char@. class CharResult m where { toCharResult :: Either JThrowable Word16 -> Java m } ; instance CharResult Word16 where { toCharResult = either (\exc -> toString exc >>= fail) return } ; instance CharResult (Either JThrowable Word16) where { toCharResult = return } -- | The result of a function call that is of type @byte@. class ByteResult m where { toByteResult :: Either JThrowable Int8 -> Java m } ; instance ByteResult Int8 where { toByteResult = either (\exc -> toString exc >>= fail) return } ; instance ByteResult (Either JThrowable Int8) where { toByteResult = return } -- | The result of a function call that is of type @short@. class ShortResult m where { toShortResult :: Either JThrowable Int16 -> Java m } ; instance ShortResult Int16 where { toShortResult = either (\exc -> toString exc >>= fail) return } ; instance ShortResult (Either JThrowable Int16) where { toShortResult = return } -- | The result of a function call that is of type @int@. class IntResult m where { toIntResult :: Either JThrowable Int32 -> Java m } ; instance IntResult Int32 where { toIntResult = either (\exc -> toString exc >>= fail) return } ; instance IntResult (Either JThrowable Int32) where { toIntResult = return } -- | The result of a function call that is of type @long@. class LongResult m where { toLongResult :: Either JThrowable Int64 -> Java m } ; instance LongResult Int64 where { toLongResult = either (\exc -> toString exc >>= fail) return } ; instance LongResult (Either JThrowable Int64) where { toLongResult = return } -- | The result of a function call that is of type @float@. class FloatResult m where { toFloatResult :: Either JThrowable Float -> Java m } ; instance FloatResult Float where { toFloatResult = either (\exc -> toString exc >>= fail) return } ; instance FloatResult (Either JThrowable Float) where { toFloatResult = return } -- | The result of a function call that is of type @double@. class DoubleResult m where { toDoubleResult :: Either JThrowable Double -> Java m } ; instance DoubleResult Double where { toDoubleResult = either (\exc -> toString exc >>= fail) return } ; instance DoubleResult (Either JThrowable Double) where { toDoubleResult = return } -- | The result of a function call that is of type @void@. class VoidResult m where toVoidResult :: Either JThrowable () -> Java m instance VoidResult () where toVoidResult = either (\exc -> toString exc >>= fail) return instance VoidResult (Either JThrowable ()) where toVoidResult = return instance VoidResult (Maybe JThrowable) where toVoidResult = return . either Just (const Nothing) ------------------------ -- Array result types -- ------------------------ -- | An array result of a function call. class JavaArray (ArrayResultType m) (ArrayResultComponent m) => ArrayResult m where -- | The JVM machine type of the components of the array. type ArrayResultType m -- | The type of the component of the array as returned by -- the low level JNI call. type ArrayResultComponent m -- | Convert the array to a sophisticated type. toArrayResult :: Either JThrowable (Maybe (JArray (ArrayResultType m))) -> Java m instance ArrayResult a => ArrayResult (Either JThrowable a) where type ArrayResultType (Either JThrowable a) = ArrayResultType a type ArrayResultComponent (Either JThrowable a) = ArrayResultComponent a toArrayResult = either (return . Left) (toArrayResult . Right) instance ArrayResult [Bool] where { type ArrayResultType [Bool] = T.Z ; type ArrayResultComponent [Bool] = Bool ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Word16] where { type ArrayResultType [Word16] = T.C ; type ArrayResultComponent [Word16] = Word16 ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Int8] where { type ArrayResultType [Int8] = T.B ; type ArrayResultComponent [Int8] = Int8 ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Int16] where { type ArrayResultType [Int16] = T.S ; type ArrayResultComponent [Int16] = Int16 ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Int32] where { type ArrayResultType [Int32] = T.I ; type ArrayResultComponent [Int32] = Int32 ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Int64] where { type ArrayResultType [Int64] = T.J ; type ArrayResultComponent [Int64] = Int64 ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Float] where { type ArrayResultType [Float] = T.F ; type ArrayResultComponent [Float] = Float ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Double] where { type ArrayResultType [Double] = T.D ; type ArrayResultComponent [Double] = Double ; toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) toList) } instance ArrayResult [Char] where type ArrayResultType [Char] = T.C type ArrayResultComponent [Char] = Word16 toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) (fmap (map (toEnum . fromIntegral)) . toList)) instance ArrayResult [String] where type ArrayResultType [String] = T.L type ArrayResultComponent [String] = Maybe JObject toArrayResult = either (\exc -> toString exc >>= fail) (maybe (return []) (\arr -> toList arr >>= mapM (maybe (return "") toString))) ----------------------- -- All other objects -- ----------------------- -- | The result of a function call that is of type @object@. class ObjectResult m where -- | toObjectResult :: Either JThrowable (Maybe JObject) -> Java m instance UnsafeCast a => ObjectResult (Value JThrowable a) where toObjectResult = either (return . Fail) (maybe (return NoValue) (fmap Value . unsafeFromJObject)) instance UnsafeCast a => ObjectResult (Either (Maybe JThrowable) a) where toObjectResult = either (return . Left . Just) (maybe (return (Left Nothing)) (fmap Right . unsafeFromJObject)) instance UnsafeCast a => ObjectResult (Either JThrowable (Maybe a)) where toObjectResult = either (return . Left) (fmap Right . maybe (return Nothing) (fmap Just . unsafeFromJObject)) instance UnsafeCast a => ObjectResult (Maybe a) where toObjectResult = either (\exc -> toString exc >>= fail) (maybe (return Nothing) (fmap Just . unsafeFromJObject)) instance ObjectResult [Char] where toObjectResult = either (\exc -> toString exc >>= fail) (maybe (return "null") toString) --------------------------------------------------- -- Advanced features (Callbacks, Subtyping, ...) -- --------------------------------------------------- -- | A convenient alternative to 'isInstanceOf'. -- -- Minimal complete definition: 'coerce' or 'whenInstanceOf'. class InstanceOf a where type CoercedType a -- | Check if the object of type @a@ is an instance -- of the type represented by @b@. instanceOf :: JavaObject o => o -> a -> Java Bool -- | Check if the object of type @a@ is an instance -- of the type @c@, represented by @b@. If so, it will coerce -- the object of type @a@ and pass it to the given action. -- -- If @a@ was an instance of @c@ (where @c@ is represented -- by @b@) this function will return @'Just' d@, where @d@ is -- the result of the optional computation. If not, 'Nothing' -- is returned. whenInstanceOf :: JavaObject o => o -> a -> (CoercedType a -> Java d) -> Java (Maybe d) -- | Coerces the given object of type @a@ to an object of -- @c@, where @c@ is represented by a value of type @b@. -- Returns @'Nothing'@ if this is not possible. coerce :: JavaObject o => o -> a -> Java (Maybe (CoercedType a)) instanceOf o t = whenInstanceOf o t (return . const ()) >>= return . maybe False (const True) whenInstanceOf o t a = coerce o t >>= maybe (return Nothing) (fmap Just . a) coerce o t = whenInstanceOf o t return -- | For INTERNAL use only. Is however not in a hidden module, -- so that other libraries can link against it. class UnsafeCast a where -- | For INTERNAL use only. Do not use yourself. unsafeFromJObject :: JObject -> Java a --------------- -- Callbacks -- --------------- registerCallbacks :: Core.JClass -> Java Bool -- ^ Yepp. Register callbacks. Do it. registerCallbacks (Core.JClass ptr) = do vm <- getVM io $ withForeignPtr ptr $ \clazz -> JNI.registerCallbacks vm clazz type WrappedFun = Ptr Core.JVM -> Ptr Core.JObjectRef -> Ptr Core.JObjectRef -> Ptr Core.JObjectRef -> IO (Ptr Core.JObjectRef) runJava_ :: Ptr Core.JVM -> Java a -> IO a runJava_ vm f = runStateT (_runJava f) (newJVMState vm) >>= return . fst foreign import ccall safe "wrapper" wrap_ :: WrappedFun -> IO (FunPtr WrappedFun) foreign export ccall freeFunPtr :: FunPtr WrappedFun -> IO () freeFunPtr :: FunPtr WrappedFun -> IO () freeFunPtr ptr = freeHaskellFunPtr ptr wrap :: Java () -> IO (FunPtr WrappedFun) wrap f = do let func vm _self _method _args = do runJava_ vm f return nullPtr func' <- wrap_ func return func' intify :: Java () -> IO Int64 intify = fmap (fromIntegral . ptrToIntPtr . castFunPtrToPtr) . wrap sushimaki :: String -> Java () -> Java JObject sushimaki ifaceName func = do iface <- getClass ifaceName >>= asObject . fromJust (Just clazz) <- getClass "HFunction" _success <- registerCallbacks clazz makeFunction <- clazz `bindStaticMethod` "makeFunction" ::= object "java.lang.Class" --> long --> object "java.lang.Object" (Just impl) <- io (intify func) >>= makeFunction (Just iface) return impl delete :: Core.JObject -> Java () delete (Core.JObject ptr) = io $ do finalizeForeignPtr ptr