diff --git a/dist/build/Foreign/Java.hs b/dist/build/Foreign/Java.hs --- a/dist/build/Foreign/Java.hs +++ b/dist/build/Foreign/Java.hs @@ -213,14 +213,21 @@ asObject :: a -> Java JObject -- | Returns a reference to the Class of the given object. - classOf :: a -> Java JClass + classOf :: a -> Java JClass + -- | Returns a string representation of the type. + jtypeOf :: a -> Java String + -- | Checks two objects for equality using their @equals@ methods. equals :: JavaObject b => a -> b -> Java Bool toString obj = asObject obj >>= toString hashCode obj = asObject obj >>= hashCode classOf obj = asObject obj >>= classOf + jtypeOf obj = do + (Just clazz) <- getClass "java.lang.Class" + getName <- clazz `bindMethod` "getName" ::= string + classOf obj >>= asObject >>= getName >>= return . maybe "" id equals this obj = do this' <- asObject this diff --git a/dist/build/Foreign/Java/Bindings.hs b/dist/build/Foreign/Java/Bindings.hs --- a/dist/build/Foreign/Java/Bindings.hs +++ b/dist/build/Foreign/Java/Bindings.hs @@ -4,6 +4,9 @@ , FlexibleContexts , FlexibleInstances , TypeSynonymInstances + , MultiParamTypeClasses + , ScopedTypeVariables + , NoImplicitPrelude #-} {-# OPTIONS -Wall @@ -23,15 +26,12 @@ -- not be imported directly. module Foreign.Java.Bindings where -import Control.Monad.State hiding (void) +import Haskell.X.Prelude hiding (toList, arr) -import Data.Int -import Data.Word -import Data.Maybe +import Control.Monad.State hiding (void) -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.C.Types +import Foreign +import Foreign.C import Foreign.Java import Foreign.Java.JavaMonad @@ -45,7 +45,7 @@ --------------- -object' :: String -> Q +object' :: [Char] -> Q object' = T.object' @@ -199,9 +199,9 @@ (maybe (return []) (fmap (map (toEnum . fromIntegral)) . toList)) -instance ArrayResult [String] where - type ArrayResultType [String] = T.L - type ArrayResultComponent [String] = Maybe JObject +instance ArrayResult [[Char]] where + type ArrayResultType [[Char]] = T.L + type ArrayResultComponent [[Char]] = Maybe JObject toArrayResult = either (\exc -> toString exc >>= fail) @@ -214,37 +214,55 @@ -- All other objects -- ----------------------- +newtype AsString o = AsString [Char] + deriving (Eq, Show, Ord) +newtype AsList a o = AsList [a] + deriving (Eq, Show, Ord) + +class ObjectToList o e where + objectToList :: o -> JObject -> Java [e] + -- | 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 +instance ObjectResult (AsString a) where + toObjectResult = fmap AsString . either (\exc -> toString exc >>= fail) + (maybe (return "null") toString) + +instance ObjectToList o e => ObjectResult (AsList e o) where + toObjectResult = fmap AsList . either (\exc -> toString exc >>= fail) + (maybe (return []) (objectToList (undefined :: o))) + +instance UnsafeCast a => ObjectResult (Value a) where toObjectResult = either (return . Fail) (maybe (return NoValue) (fmap Value . unsafeFromJObject)) +instance UnsafeCast a => ObjectResult (Either JThrowable a) where + toObjectResult = either (return . Left) + (maybe (fmap Left nullPointer) + (fmap Right . unsafeFromJObject)) + where + nullPointer :: Java JThrowable + nullPointer = do + (Just clazz) <- getClass "java.lang.NullPointerException" + (Just (Core.JObject obj)) <- newObject clazz + return $ Core.JThrowable (castForeignPtr obj) + 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, ...) -- --------------------------------------------------- @@ -303,45 +321,32 @@ vm <- getVM io $ withForeignPtr ptr $ \clazz -> JNI.registerCallbacks vm clazz + -- | A wrapped function can be used as a callback from the -- JVM into the Haskell runtime environment. -type WrappedFun = Ptr Core.JVM -- Ptr to JEnv +type WrappedFunc = Ptr Core.JVM -- Ptr to JEnv -> Ptr Core.JObjectRef -- Ptr to this, a proxy -> Ptr Core.JObjectRef -- Ptr to method, the requested method -> Ptr Core.JObjectRef -- Ptr to a JObject-Array (Object[]), the arguments -> IO (Ptr Core.JObjectRef) -- Returns a pointer to the result +type InterfaceFunc = JObject -> JObject -> JObject -> Java (Maybe JObject) 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) + wrap_ :: WrappedFunc -> IO (FunPtr WrappedFunc) -foreign export ccall freeFunPtr :: FunPtr WrappedFun -> IO () +foreign export ccall freeFunPtr :: FunPtr WrappedFunc -> IO () -freeFunPtr :: FunPtr WrappedFun -> IO () +freeFunPtr :: FunPtr WrappedFunc -> 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 +implementInterfaceBy :: [Char] -> InterfaceFunc -> Java JObject +implementInterfaceBy ifaceName func = do iface <- getClass ifaceName >>= asObject . fromJust (Just clazz) <- getClass "HFunction" _success <- registerCallbacks clazz @@ -349,6 +354,27 @@ ::= object "java.lang.Class" --> long --> object "java.lang.Object" (Just impl) <- io (intify func) >>= makeFunction (Just iface) return impl + where + wrap :: InterfaceFunc -> IO (FunPtr WrappedFunc) + wrap f = do + + let proxyFunc vm self method args = do + self' <- Core.JObject <$> newForeignPtr JNI.release self + method' <- Core.JObject <$> newForeignPtr JNI.release method + args' <- Core.JObject <$> newForeignPtr JNI.release args + + jobj <- runJava_ vm (f self' method' args') + + case jobj of + Nothing -> return nullPtr + Just (Core.JObject ptr) -> withForeignPtr ptr return + + wrappedFunc <- wrap_ proxyFunc + + return wrappedFunc + + intify :: InterfaceFunc -> IO Int64 + intify = fmap (fromIntegral . ptrToIntPtr . castFunPtrToPtr) . wrap delete :: Core.JObject -> Java () diff --git a/java-bridge.cabal b/java-bridge.cabal --- a/java-bridge.cabal +++ b/java-bridge.cabal @@ -1,5 +1,5 @@ name: java-bridge -version: 0.9 +version: 0.99 license: MIT license-file: LICENSE @@ -154,6 +154,7 @@ , strings >= 1.1 , mtl >= 2.1.1 , transformers >= 0.3 + , hx >= 0.4 other-modules: Foreign.Java.Types , Foreign.Java.JavaMonad diff --git a/src/Foreign/Java.cpphs b/src/Foreign/Java.cpphs --- a/src/Foreign/Java.cpphs +++ b/src/Foreign/Java.cpphs @@ -212,14 +212,21 @@ asObject :: a -> Java JObject -- | Returns a reference to the Class of the given object. - classOf :: a -> Java JClass + classOf :: a -> Java JClass + -- | Returns a string representation of the type. + jtypeOf :: a -> Java String + -- | Checks two objects for equality using their @equals@ methods. equals :: JavaObject b => a -> b -> Java Bool toString obj = asObject obj >>= toString hashCode obj = asObject obj >>= hashCode classOf obj = asObject obj >>= classOf + jtypeOf obj = do + (Just clazz) <- getClass "java.lang.Class" + getName <- clazz `bindMethod` "getName" ::= string + classOf obj >>= asObject >>= getName >>= return . maybe "" id equals this obj = do this' <- asObject this diff --git a/src/Foreign/Java/Bindings.cpphs b/src/Foreign/Java/Bindings.cpphs --- a/src/Foreign/Java/Bindings.cpphs +++ b/src/Foreign/Java/Bindings.cpphs @@ -3,6 +3,9 @@ , FlexibleContexts , FlexibleInstances , TypeSynonymInstances + , MultiParamTypeClasses + , ScopedTypeVariables + , NoImplicitPrelude #-} {-# OPTIONS -Wall @@ -22,15 +25,12 @@ -- not be imported directly. module Foreign.Java.Bindings where -import Control.Monad.State hiding (void) +import Haskell.X.Prelude hiding (toList, arr) -import Data.Int -import Data.Word -import Data.Maybe +import Control.Monad.State hiding (void) -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.C.Types +import Foreign +import Foreign.C import Foreign.Java import Foreign.Java.JavaMonad @@ -44,7 +44,7 @@ --------------- -object' :: String -> Q +object' :: [Char] -> Q object' = T.object' @@ -198,9 +198,9 @@ (maybe (return []) (fmap (map (toEnum . fromIntegral)) . toList)) -instance ArrayResult [String] where - type ArrayResultType [String] = T.L - type ArrayResultComponent [String] = Maybe JObject +instance ArrayResult [[Char]] where + type ArrayResultType [[Char]] = T.L + type ArrayResultComponent [[Char]] = Maybe JObject toArrayResult = either (\exc -> toString exc >>= fail) @@ -213,37 +213,55 @@ -- All other objects -- ----------------------- +newtype AsString o = AsString [Char] + deriving (Eq, Show, Ord) +newtype AsList a o = AsList [a] + deriving (Eq, Show, Ord) + +class ObjectToList o e where + objectToList :: o -> JObject -> Java [e] + -- | 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 +instance ObjectResult (AsString a) where + toObjectResult = fmap AsString . either (\exc -> toString exc >>= fail) + (maybe (return "null") toString) + +instance ObjectToList o e => ObjectResult (AsList e o) where + toObjectResult = fmap AsList . either (\exc -> toString exc >>= fail) + (maybe (return []) (objectToList (undefined :: o))) + +instance UnsafeCast a => ObjectResult (Value a) where toObjectResult = either (return . Fail) (maybe (return NoValue) (fmap Value . unsafeFromJObject)) +instance UnsafeCast a => ObjectResult (Either JThrowable a) where + toObjectResult = either (return . Left) + (maybe (fmap Left nullPointer) + (fmap Right . unsafeFromJObject)) + where + nullPointer :: Java JThrowable + nullPointer = do + (Just clazz) <- getClass "java.lang.NullPointerException" + (Just (Core.JObject obj)) <- newObject clazz + return $ Core.JThrowable (castForeignPtr obj) + 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, ...) -- --------------------------------------------------- @@ -302,45 +320,32 @@ vm <- getVM io $ withForeignPtr ptr $ \clazz -> JNI.registerCallbacks vm clazz + -- | A wrapped function can be used as a callback from the -- JVM into the Haskell runtime environment. -type WrappedFun = Ptr Core.JVM -- Ptr to JEnv +type WrappedFunc = Ptr Core.JVM -- Ptr to JEnv -> Ptr Core.JObjectRef -- Ptr to this, a proxy -> Ptr Core.JObjectRef -- Ptr to method, the requested method -> Ptr Core.JObjectRef -- Ptr to a JObject-Array (Object[]), the arguments -> IO (Ptr Core.JObjectRef) -- Returns a pointer to the result +type InterfaceFunc = JObject -> JObject -> JObject -> Java (Maybe JObject) 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) + wrap_ :: WrappedFunc -> IO (FunPtr WrappedFunc) -foreign export ccall freeFunPtr :: FunPtr WrappedFun -> IO () +foreign export ccall freeFunPtr :: FunPtr WrappedFunc -> IO () -freeFunPtr :: FunPtr WrappedFun -> IO () +freeFunPtr :: FunPtr WrappedFunc -> 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 +implementInterfaceBy :: [Char] -> InterfaceFunc -> Java JObject +implementInterfaceBy ifaceName func = do iface <- getClass ifaceName >>= asObject . fromJust (Just clazz) <- getClass "HFunction" _success <- registerCallbacks clazz @@ -348,6 +353,27 @@ ::= object "java.lang.Class" --> long --> object "java.lang.Object" (Just impl) <- io (intify func) >>= makeFunction (Just iface) return impl + where + wrap :: InterfaceFunc -> IO (FunPtr WrappedFunc) + wrap f = do + + let proxyFunc vm self method args = do + self' <- Core.JObject <$> newForeignPtr JNI.release self + method' <- Core.JObject <$> newForeignPtr JNI.release method + args' <- Core.JObject <$> newForeignPtr JNI.release args + + jobj <- runJava_ vm (f self' method' args') + + case jobj of + Nothing -> return nullPtr + Just (Core.JObject ptr) -> withForeignPtr ptr return + + wrappedFunc <- wrap_ proxyFunc + + return wrappedFunc + + intify :: InterfaceFunc -> IO Int64 + intify = fmap (fromIntegral . ptrToIntPtr . castFunPtrToPtr) . wrap delete :: Core.JObject -> Java () diff --git a/src/Foreign/Java/JavaMonad.hs b/src/Foreign/Java/JavaMonad.hs --- a/src/Foreign/Java/JavaMonad.hs +++ b/src/Foreign/Java/JavaMonad.hs @@ -144,7 +144,7 @@ -- Use one of 'runJava' or 'runJava'' to perform operations in the -- Java monad. newtype Java a = Java { _runJava :: StateT JVMState IO a } - deriving (Monad, MonadState JVMState, Functor, MonadIO) + deriving (Monad, MonadState JVMState, Functor, MonadIO) -- | INTERNAL Retrieve the 'jvmPtr' from this Java Monads -- State. diff --git a/src/Foreign/Java/Value.hs b/src/Foreign/Java/Value.hs --- a/src/Foreign/Java/Value.hs +++ b/src/Foreign/Java/Value.hs @@ -17,18 +17,20 @@ -- nothing, or a special value describing an error condition. module Foreign.Java.Value where +import Foreign.Java.JNI.Types (JThrowable) + -- | A ternary value type to hold one of two possible value types -- or none at all. -data Value e a +data Value a = Value a -- ^ An actual value | NoValue -- ^ No value - | Fail e -- ^ A value describing the error + | Fail JThrowable -- ^ A value describing the error -- | fold on a 'Value', like 'either' for 'Either' or 'maybe' for 'Maybe'. value :: b -- ^ default value if neither a value nor a fail value is given - -> (e -> b) -- ^ function to handle a fail value + -> (JThrowable -> b) -- ^ function to handle a fail value -> (a -> b) -- ^ function to handle an actual value - -> Value e a -- ^ the value + -> Value a -- ^ the value -> b -- ^ the final return value value noValue fail success value = case value of (Value a) -> success a