diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,15 +16,15 @@ ```Haskell {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} import Data.Text (Text) import Language.Java newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) -instance Coercible JOptionPane ('Class "javax.swing.JOptionPane") + deriving Coercible main :: IO () main = withJVM [] $ do @@ -32,7 +32,8 @@ callStatic (classOf (undefined :: JOptionPane)) "showMessageDialog" - [JObject nullComponent, JObject (upcast message)] + nullComponent + (upcast message) where nullComponent :: J ('Class "java.awt.Component") nullComponent = jnull diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -8,25 +8,27 @@ import Control.DeepSeq (NFData(..)) import Criterion.Main as Criterion -import Control.Monad (replicateM_) +import Control.Monad (replicateM, replicateM_, void) import Data.Int +import Data.IORef import Data.Singletons (SomeSing(..)) +import Data.Text (Text) import qualified Foreign.Concurrent as Concurrent import qualified Foreign.ForeignPtr as ForeignPtr import Foreign.JNI -import Foreign.Marshal.Alloc (mallocBytes, finalizerFree) +import Foreign.Marshal.Alloc (mallocBytes, finalizerFree, free) +import Foreign.Marshal.Array (callocArray, mallocArray) +import Foreign.Ptr (castPtr) import Language.Java -newtype BoxObject = BoxObject JObject -newtype BoxClass = BoxClass JClass +newtype Box a = Box { unBox :: a } -- Not much sense in deepseq'ing foreign pointers. But needed for call to 'env' -- below. -instance NFData BoxObject where rnf (BoxObject (J fptr)) = fptr `seq` () -instance NFData BoxClass where rnf (BoxClass (J fptr)) = fptr `seq` () +instance NFData (Box a) where rnf (Box a) = seq a () jabs :: Int32 -> IO Int32 -jabs x = callStatic "java.lang.Math" "abs" [coerce x] +jabs x = callStatic "java.lang.Math" "abs" x jniAbs :: JClass -> JMethodID -> Int32 -> IO Int32 jniAbs klass method x = callStaticIntMethod klass method [coerce x] @@ -34,13 +36,13 @@ intValue :: Int32 -> IO Int32 intValue x = do jx <- reflect x - call jx "intValue" [] + call jx "intValue" compareTo :: Int32 -> Int32 -> IO Int32 compareTo x y = do jx <- reflect x jy <- reflect y - call jx "compareTo" [coerce jy] + call jx "compareTo" jy incrHaskell :: Int32 -> IO Int32 incrHaskell x = return (x + 1) @@ -49,27 +51,45 @@ benchCalls :: Benchmark benchCalls = - env ini $ \ ~(BoxClass klass, method) -> + env ini $ \ ~(Box klass, method) -> bgroup "Calls" [ bgroup "Java calls" [ bench "static method call: unboxed single arg / unboxed return" $ nfIO $ jabs 1 + , bench "static method call: boxed single arg / boxed return" $ + perBatchEnvWithCleanup + (\batchSize -> do + pushLocalFrame (2 * fromIntegral batchSize) + Box <$> reflect ("123" :: Text) + ) + (\_ _ -> void (popLocalFrame jnull)) $ + \(Box jStringInteger) -> do + _ <- callStatic "java.lang.Integer" "valueOf" jStringInteger + :: IO (J ('Class "java.lang.Integer")) + return () , bench "jni static method call: unboxed single arg / unboxed return" $ nfIO $ jniAbs klass method 1 , bench "method call: no args / unboxed return" $ nfIO $ intValue 1 , bench "method call: boxed single arg / unboxed return" $ nfIO $ compareTo 1 1 - , bench "local frame / 1 reference" $ nfIO $ do - pushLocalFrame 30 - _ <- newLocalRef klass - _ <- popLocalFrame jnull - return () - , bench "delete 1 local ref" $ nfIO $ - newLocalRef klass >>= deleteLocalRef - , bench "local frame / 30 references" $ nfIO $ do - pushLocalFrame 30 - replicateM_ 30 $ newLocalRef klass - _ <- popLocalFrame jnull - return () - , bench "delete 30 local refs" $ nfIO $ - replicateM_ 30 $ newLocalRef klass >>= deleteLocalRef + , bench "getClass" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> do + _ <- getClass (SClass "java/lang/Math") + return () + , bench "getStaticMethodID" $ + perBatchEnvWithCleanup + (\_ -> Box <$> getClass (SClass "java/lang/Math")) + (\_ (Box c) -> deleteLocalRef c) $ + \ ~(Box c) -> do + _ <- getStaticMethodID c "abs" absSignature + return () + , bench "getMethodID" $ + perBatchEnvWithCleanup + (\_ -> Box <$> getClass (SClass "java/lang/Integer")) + (\_ (Box c) -> deleteLocalRef c) $ + \ ~(Box c) -> do + _ <- getMethodID c "intValue" (methodSignature [] (SPrim "int")) + return () ] , bgroup "Haskell calls" [ bench "incr haskell" $ nfIO $ incrHaskell 1 @@ -77,14 +97,15 @@ ] ] where + absSignature = methodSignature [SomeSing (sing :: Sing ('Prim "int"))] (SPrim "int") ini = do klass <- findClass (referenceTypeName (SClass "java/lang/Math")) - method <- getStaticMethodID klass "abs" (methodSignature [SomeSing (sing :: Sing ('Prim "int"))] (SPrim "int")) - return (BoxClass klass, method) + method <- getStaticMethodID klass "abs" absSignature + return (Box klass, method) benchRefs :: Benchmark benchRefs = - env (BoxObject <$> new []) $ \ ~(BoxObject jobj) -> + env (Box <$> (new >>= newGlobalRefNonFinalized)) $ \ ~(Box (jobj :: JObject)) -> bgroup "References" [ bench "local reference" $ nfIO $ do _ <- newLocalRef jobj @@ -95,6 +116,20 @@ , bench "global reference (no finalizer)" $ nfIO $ do _ <- newGlobalRefNonFinalized jobj return () + -- The next three benchmarks are to be compared with one another: + -- The goal is to evaluate the cost of attaching a thread to the JVM + -- when deleting a non-finalized global ref, versus the cost + -- of having a dedicated thread to do the deleting + , bench "delete global reference in attached thread" $ nfIO $ + newGlobalRefNonFinalized jobj >>= deleteGlobalRefNonFinalized + , envWithCleanup + detachCurrentThread + (const attachCurrentThreadAsDaemon) $ + \_ -> bench "delete global reference in non-attached thread" $ nfIO $ runInAttachedThread $ + newGlobalRefNonFinalized jobj >>= deleteGlobalRefNonFinalized + , bench "pass global references to another thread for deletion" $ nfIO $ + newGlobalRefNonFinalized jobj >>= + submitToFinalizerThread . deleteGlobalRefNonFinalized , bench "Foreign.Concurrent.newForeignPtr" $ nfIO $ do _ <- Concurrent.newForeignPtr (unsafeObjectToPtr jobj) (return ()) return () @@ -104,8 +139,142 @@ ptr <- mallocBytes 4 _ <- ForeignPtr.newForeignPtr finalizerFree ptr return () + , bench "local frame / 1 reference" $ nfIO $ do + pushLocalFrame 30 + _ <- newLocalRef jobj + _ <- popLocalFrame jnull + return () + , bench "delete 1 local ref" $ nfIO $ + newLocalRef jobj >>= deleteLocalRef + , bench "local frame / 30 references" $ nfIO $ do + pushLocalFrame 30 + replicateM_ 30 $ newLocalRef jobj + _ <- popLocalFrame jnull + return () + , bench "delete 30 local refs" $ nfIO $ + replicateM_ 30 $ newLocalRef jobj >>= deleteLocalRef ] +benchNew :: Benchmark +benchNew = + bgroup "new" + [ bench "Integer" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> do + _ <- new (2 :: Int32) :: IO (J ('Class "java.lang.Integer")) + return () + , bench "Integer.valueOf" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> do + _ <- callStatic "java.lang.Integer" "valueOf" (2 :: Int32) + :: IO (J ('Class "java.lang.Integer")) + return () + , envWithCleanup allocTextPtr freeTextPtr $ \ ~(Box (ptr, len)) -> + bench "newString" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> + void $ newString ptr (fromIntegral len) + , envWithCleanup allocTextPtr freeTextPtr $ \ ~(Box (_ptr, len)) -> + bench "newArray" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> + void $ newByteArray (fromIntegral len) + , envWithCleanup allocTextPtr freeTextPtr $ \ ~(Box (ptr, len)) -> + bench "newDirectByteBuffer" $ + perBatchEnvWithCleanup + (pushLocalFrame . (2*) . fromIntegral) + (\_ _ -> void (popLocalFrame jnull)) $ + \() -> + void $ newDirectByteBuffer (castPtr ptr) (2 * len) + ] + where + allocTextPtr = do + let len = 128 + dst <- callocArray len + return $ Box (dst, fromIntegral len) + freeTextPtr (Box (p, _)) = free p + +benchArrays :: Benchmark +benchArrays = + bgroup "Arrays" $ (++ otherBenchmarks) $ (`map` [128, 256, 512]) $ \arraySize -> + let n :: Num b => b + n = fromIntegral (arraySize :: Int) in + env (Box <$> mallocArray n) $ \ ~(Box bytes) -> + env (Box <$> newArray n) $ \ ~(Box jbytes) -> + bgroup (show (n :: Int)) + [ bench "getByteArrayElements" $ + perBatchEnvWithCleanup (\_ -> newIORef []) (const cleanArrays) $ + \ref -> do + p <- getByteArrayElements jbytes + modifyIORef ref ((jbytes, p) :) + , bench "releaseByteArrayElements" $ + perBatchEnv + (\batchSize -> + replicateM (fromIntegral batchSize) (getByteArrayElements jbytes) + >>= newIORef + ) $ + \ref -> do + arrays <- readIORef ref + case arrays of + x : xs -> do + releaseByteArrayElements jbytes x + writeIORef ref xs + _ -> error "not enough arrays" + , bench "getByteArrayRegion" $ nfIO $ + getByteArrayRegion jbytes 0 n bytes + , bench "setByteArrayRegion" $ nfIO $ + setByteArrayRegion jbytes 0 n bytes + ] + where + otherBenchmarks = + [ bench "getObjectArrayElement" $ + perBatchEnvWithCleanup + (\batchSize -> do + pushLocalFrame (2 * fromIntegral batchSize) + Box <$> newArray 100 + ) + (\_ _ -> void (popLocalFrame jnull)) $ + \(Box jObjectArray) -> do + _ <- getObjectArrayElement (jObjectArray :: JObjectArray) 40 :: IO JObject + return () + ] + + cleanArrays ref = + readIORef ref >>= mapM_ (uncurry releaseByteArrayElements) + +benchDirectBuffers :: Benchmark +benchDirectBuffers = + bgroup "DirectBuffers" $ (`map` [128, 256, 512]) $ \bufferSize -> + let n :: Num b => b + n = fromIntegral (bufferSize :: Int) in + env (Box <$> mallocArray n) $ \ ~(Box bytes) -> + bgroup (show bufferSize) + [ bench "getDirectBufferAddress" $ + perBatchEnvWithCleanup + (\_ -> Box <$> newDirectByteBuffer bytes n) + (\_ -> deleteLocalRef . unBox) $ + void . getDirectBufferAddress . unBox + , bench "getDirectBufferCapacity" $ + perBatchEnvWithCleanup + (\_ -> Box <$> newDirectByteBuffer bytes n) + (\_ -> deleteLocalRef . unBox) $ + void . getDirectBufferCapacity . unBox + ] + main :: IO () main = withJVM [] $ do - Criterion.defaultMain [benchCalls, benchRefs] + Criterion.defaultMain + [ benchCalls + , benchRefs + , benchNew + , benchArrays + , benchDirectBuffers + ] diff --git a/jvm.cabal b/jvm.cabal --- a/jvm.cabal +++ b/jvm.cabal @@ -1,5 +1,5 @@ name: jvm -version: 0.4.2 +version: 0.6.0 synopsis: Call JVM methods from Haskell. description: Please see README.md. homepage: http://github.com/tweag/inline-java/tree/master/jvm#readme @@ -18,21 +18,36 @@ location: https://github.com/tweag/inline-java subdir: jvm +flag linear-types + description: Build the linear types interface. + default: False + library - hs-source-dirs: src + hs-source-dirs: src/common exposed-modules: Language.Java + Language.Java.Internal + Language.Java.Unsafe build-depends: - base >=4.7 && <5, + base >=4.14 && <5, bytestring >=0.10, constraints >=0.8, choice >=0.1, distributed-closure >=0.3, exceptions >=0.8, - jni >=0.4.0 && <0.7, - singletons >=2.0, + jni >=0.8.0 && <0.9, text >=1.2, + template-haskell, vector >=0.11 + if flag(linear-types) + hs-source-dirs: src/linear-types + exposed-modules: + Language.Java.Safe + build-depends: + linear-base ==0.1.0.0 + else + build-depends: + singletons >=2.6 default-language: Haskell2010 test-suite spec @@ -49,9 +64,13 @@ hspec, jni, jvm, + QuickCheck, + quickcheck-text, text default-language: Haskell2010 extra-libraries: pthread + ghc-options: -threaded + cpp-options: -DHSPEC_DISCOVER=hspec-discover benchmark micro-benchmarks type: exitcode-stdio-1.0 @@ -63,6 +82,7 @@ deepseq >=1.4.2, jni, jvm, - singletons + singletons, + text >=1.2 default-language: Haskell2010 ghc-options: -threaded diff --git a/src/Language/Java.hs b/src/Language/Java.hs deleted file mode 100644 --- a/src/Language/Java.hs +++ /dev/null @@ -1,793 +0,0 @@ --- | High-level helper functions for interacting with Java objects, mapping them --- to Haskell values and vice versa. The 'Reify' and 'Reflect' classes together --- are to Java what "Foreign.Storable" is to C: they provide a means to --- marshall/unmarshall Java objects from/to Haskell data types. --- --- A typical pattern for wrapping Java API's using this module is: --- --- @ --- {-\# LANGUAGE DataKinds \#-} --- {-\# LANGUAGE DeriveAnyClass \#-} --- module Object where --- --- import Language.Java as J --- --- newtype Object = Object ('J' (''Class' "java.lang.Object")) --- deriving (J.Coercible, J.Interpretation, J.Reify, J.Reflect) --- --- clone :: Object -> IO Object --- clone obj = J.'call' obj "clone" [] --- --- equals :: Object -> Object -> IO Bool --- equals obj1 obj2 = J.'call' obj1 "equals" ['jvalue' obj2] --- --- ... --- @ --- --- To call Java methods using quasiquoted Java syntax instead, see --- "Language.Java.Inline". --- --- __NOTE 1:__ To use any function in this module, you'll need an initialized --- JVM in the current process, using 'withJVM' or otherwise. --- --- __NOTE 2:__ Functions in this module memoize (cache) any implicitly performed --- class and method lookups, for performance. This memoization is safe only when --- no new named classes are defined at runtime. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StaticPointers #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Java - ( module Foreign.JNI.Types - -- * JVM instance management - , withJVM - -- * JVM calls - , classOf - , new - , newArray - , toArray - , call - , callStatic - , getStaticField - -- * Reference management - , push - , pushWithSizeHint - , Pop(..) - , pop - , popWithObject - , popWithValue - , withLocalRef - -- * Coercions - , CoercionFailure(..) - , Coercible(..) - , jvalue - , jobject - -- * Conversions - , Interpretation(..) - , Reify(..) - , Reflect(..) - -- * Re-exports - , sing - ) where - -import Control.Distributed.Closure.TH -import Control.Exception (Exception, throw, finally) -import Control.Monad -import Control.Monad.Catch (MonadCatch, MonadMask, bracket, onException) -import Control.Monad.IO.Class -import Data.Char (chr, ord) -import qualified Data.Choice as Choice -import qualified Data.Coerce as Coerce -import Data.Constraint (Dict(..)) -import Data.Int -import Data.Proxy (Proxy(..)) -import Data.Typeable (Typeable, TypeRep, typeOf) -import Data.Word -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Unsafe as BS -import Data.Singletons (SingI(..)) -import qualified Data.Text.Foreign as Text -import Data.Text (Text) -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) -import qualified Data.Vector.Storable as Vector -import Data.Vector.Storable (Vector) -import qualified Data.Vector.Storable.Mutable as MVector -import Data.Vector.Storable.Mutable (IOVector) -import Foreign (Ptr, Storable, withForeignPtr) -import Foreign.Concurrent (newForeignPtr) -#endif -import Foreign.C (CChar) -import Foreign.JNI hiding (throw) -import Foreign.JNI.Types -import qualified Foreign.JNI.String as JNI -import GHC.TypeLits (KnownSymbol, symbolVal) -import System.IO.Unsafe (unsafeDupablePerformIO) - -data Pop a where - PopValue :: a -> Pop a - PopObject - :: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty) - => a - -> Pop a - --- | Open a new scope for allocating (JNI) local references to JVM objects. -push :: (MonadCatch m, MonadIO m) => m (Pop a) -> m a -push = pushWithSizeHint 4 - --- | Like 'push', but specify explicitly a minimum size for the frame. You --- probably don't need this. -pushWithSizeHint :: forall a m. (MonadCatch m, MonadIO m) => Int32 -> m (Pop a) -> m a -pushWithSizeHint capacity m = do - liftIO $ pushLocalFrame capacity - m `onException` handler >>= \case - PopValue x -> do - _ <- liftIO $ popLocalFrame jnull - return x - PopObject x -> do - liftIO $ Coerce.coerce <$> popLocalFrame (jobject x) - where - handler = liftIO $ popLocalFrame jnull - --- | Equivalent to 'popWithValue ()'. -pop :: Monad m => m (Pop ()) -pop = return (PopValue ()) - --- | Pop a frame and return a JVM object. -popWithObject - :: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty, Monad m) - => a - -> m (Pop a) -popWithObject x = return (PopObject x) - --- | Pop a frame and return a value. This value MUST NOT be an object reference --- created in the popped frame. In that case use 'popWithObject' instead. -popWithValue :: Monad m => a -> m (Pop a) -popWithValue x = return (PopValue x) - --- | Create a local ref and delete it when the given action completes. -withLocalRef - :: (MonadMask m, MonadIO m, Coerce.Coercible o (J ty)) - => m o -> (o -> m a) -> m a -withLocalRef m = bracket m (liftIO . deleteLocalRef) - --- Note [Class lookup memoization] --- --- By using unsafeDupablePerformIO, we mark the lookup actions as pure. When the --- body of the function is inlined within the calling context, the lookups --- typically become closed expressions, therefore are CAF's that can be floated --- to top-level by the GHC optimizer. - --- | Tag data types that can be coerced in O(1) time without copy to a Java --- object or primitive type (i.e. have the same representation) by declaring an --- instance of this type class for that data type. -class SingI (Ty a) => Coercible a where - type Ty a :: JType - coerce :: a -> JValue - unsafeUncoerce :: JValue -> a - - default coerce - :: Coerce.Coercible a (J (Ty a)) - => a - -> JValue - coerce x = JObject (Coerce.coerce x :: J (Ty a)) - - default unsafeUncoerce - :: Coerce.Coercible (J (Ty a)) a - => JValue - -> a - unsafeUncoerce (JObject obj) = Coerce.coerce (unsafeCast obj :: J (Ty a)) - unsafeUncoerce _ = - error "Cannot unsafeUncoerce: object expected but value of primitive type found." - --- | The identity instance. -instance SingI ty => Coercible (J ty) where - type Ty (J ty) = ty - --- | A JNI call may cause a (Java) exception to be raised. This module raises it --- as a Haskell exception wrapping the Java exception. -data CoercionFailure = CoercionFailure - { coercionActual :: JValue - , coercionExpected :: TypeRep - } - -instance Exception CoercionFailure - -instance Show CoercionFailure where - show (CoercionFailure actual expected) = - "Can't coerce " ++ show actual ++ " to " ++ show expected ++ "." - -withTypeRep :: Typeable a => (TypeRep -> a) -> a -withTypeRep f = let x = f (typeOf x) in x - -instance Coercible Bool where - type Ty Bool = 'Prim "boolean" - coerce x = JBoolean (fromIntegral (fromEnum x)) - unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x) - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible CChar where - type Ty CChar = 'Prim "byte" - coerce = JByte - unsafeUncoerce (JByte x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Char where - type Ty Char = 'Prim "char" - coerce x = JChar (fromIntegral (ord x)) - unsafeUncoerce (JChar x) = chr (fromIntegral x) - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Word16 where - type Ty Word16 = 'Prim "char" - coerce = JChar - unsafeUncoerce (JChar x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Int16 where - type Ty Int16 = 'Prim "short" - coerce = JShort - unsafeUncoerce (JShort x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Int32 where - type Ty Int32 = 'Prim "int" - coerce = JInt - unsafeUncoerce (JInt x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Int64 where - type Ty Int64 = 'Prim "long" - coerce = JLong - unsafeUncoerce (JLong x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Float where - type Ty Float = 'Prim "float" - coerce = JFloat - unsafeUncoerce (JFloat x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible Double where - type Ty Double = 'Prim "double" - coerce = JDouble - unsafeUncoerce (JDouble x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) -instance Coercible () where - type Ty () = 'Void - coerce = error "Void value undefined." - unsafeUncoerce _ = () -instance Coercible (Choice.Choice a) where - type Ty (Choice.Choice a) = 'Prim "boolean" - coerce = coerce . Choice.toBool - unsafeUncoerce = Choice.fromBool . unsafeUncoerce - --- | Get the Java class of an object or anything 'Coercible' to one. -classOf - :: forall a sym. (Ty a ~ 'Class sym, Coercible a, KnownSymbol sym) - => a - -> JNI.String -classOf x = JNI.fromChars (symbolVal (Proxy :: Proxy sym)) `const` coerce x - --- | Creates a new instance of the class whose name is resolved from the return --- type. For instance, --- --- @ --- do x :: 'J' (''Class' "java.lang.Integer") <- new ['coerce' 42] --- return x --- @ -new - :: forall a sym. - ( Ty a ~ 'Class sym - , Coerce.Coercible a (J ('Class sym)) - , Coercible a - ) - => [JValue] - -> IO a -{-# INLINE new #-} -new args = do - let argsings = map jtypeOf args - voidsing = sing :: Sing 'Void - klass = unsafeDupablePerformIO $ do - lk <- findClass (referenceTypeName (sing :: Sing ('Class sym))) - gk <- newGlobalRef lk - deleteLocalRef lk - return gk - Coerce.coerce <$> newObject klass (methodSignature argsings voidsing) args - --- | Creates a new Java array of the given size. The type of the elements --- of the resulting array is determined by the return type a call to --- 'newArray' has, at the call site, and must not be left ambiguous. --- --- To create a Java array of 50 booleans: --- --- @ --- do arr :: 'J' (''Array' (''Prim' "boolean")) <- 'newArray' 50 --- return arr --- @ -newArray - :: forall ty. - SingI ty - => Int32 - -> IO (J ('Array ty)) -{-# INLINE newArray #-} -newArray sz = do - let tysing = sing :: Sing ty - case tysing of - SPrim "boolean" -> unsafeCast <$> newBooleanArray sz - SPrim "byte" -> unsafeCast <$> newByteArray sz - SPrim "char" -> unsafeCast <$> newCharArray sz - SPrim "short" -> unsafeCast <$> newShortArray sz - SPrim "int" -> unsafeCast <$> newIntArray sz - SPrim "long" -> unsafeCast <$> newLongArray sz - SPrim "float" -> unsafeCast <$> newFloatArray sz - SPrim "double" -> unsafeCast <$> newDoubleArray sz - SVoid -> fail "newArray of void" - _ -> case singToIsReferenceType tysing of - Nothing -> fail $ "newArray of " ++ show tysing - Just Dict -> do - let klass = unsafeDupablePerformIO $ do - lk <- findClass (referenceTypeName tysing) - gk <- newGlobalRef lk - deleteLocalRef lk - return gk - unsafeCast <$> newObjectArray sz klass - --- | Creates an array from a list of references. -toArray - :: forall ty. (SingI ty, IsReferenceType ty) - => [J ty] - -> IO (J ('Array ty)) -toArray xs = do - let n = fromIntegral (length xs) - jxs <- newArray n - zipWithM_ (setObjectArrayElement jxs) [0 .. n - 1] xs - return jxs - --- | The Swiss Army knife for calling Java methods. Give it an object or --- any data type coercible to one, the name of a method, and a list of --- arguments. Based on the type indexes of each argument, and based on the --- return type, 'call' will invoke the named method using of the @call*Method@ --- family of functions in the JNI API. --- --- When the method name is overloaded, use 'upcast' or 'unsafeCast' --- appropriately on the class instance and/or on the arguments to invoke the --- right method. -call - :: forall a b ty1 ty2. (ty1 ~ Ty a, ty2 ~ Ty b, IsReferenceType ty1, Coercible a, Coercible b, Coerce.Coercible a (J ty1)) - => a -- ^ Any object or value 'Coercible' to one - -> JNI.String -- ^ Method name - -> [JValue] -- ^ Arguments - -> IO b -{-# INLINE call #-} -call obj mname args = do - let argsings = map jtypeOf args - retsing = sing :: Sing ty2 - klass = unsafeDupablePerformIO $ do - lk <- findClass (referenceTypeName (sing :: Sing ty1)) - gk <- newGlobalRef lk - deleteLocalRef lk - return gk - method = unsafeDupablePerformIO $ getMethodID klass mname (methodSignature argsings retsing) - case retsing of - SPrim "boolean" -> unsafeUncoerce . coerce <$> callBooleanMethod obj method args - SPrim "byte" -> unsafeUncoerce . coerce <$> callByteMethod obj method args - SPrim "char" -> unsafeUncoerce . coerce <$> callCharMethod obj method args - SPrim "short" -> unsafeUncoerce . coerce <$> callShortMethod obj method args - SPrim "int" -> unsafeUncoerce . coerce <$> callIntMethod obj method args - SPrim "long" -> unsafeUncoerce . coerce <$> callLongMethod obj method args - SPrim "float" -> unsafeUncoerce . coerce <$> callFloatMethod obj method args - SPrim "double" -> unsafeUncoerce . coerce <$> callDoubleMethod obj method args - SVoid -> do - callVoidMethod obj method args - -- Anything uncoerces to the void type. - return (unsafeUncoerce undefined) - _ -> unsafeUncoerce . coerce <$> callObjectMethod obj method args - --- | Same as 'call', but for static methods. -callStatic - :: forall a ty. (ty ~ Ty a, Coercible a) - => JNI.String -- ^ Class name - -> JNI.String -- ^ Method name - -> [JValue] -- ^ Arguments - -> IO a -{-# INLINE callStatic #-} -callStatic cname mname args = do - let argsings = map jtypeOf args - retsing = sing :: Sing ty - klass = unsafeDupablePerformIO $ do - lk <- findClass - (referenceTypeName (SClass (JNI.toChars cname))) - gk <- newGlobalRef lk - deleteLocalRef lk - return gk - method = unsafeDupablePerformIO $ getStaticMethodID klass mname (methodSignature argsings retsing) - case retsing of - SPrim "boolean" -> unsafeUncoerce . coerce <$> callStaticBooleanMethod klass method args - SPrim "byte" -> unsafeUncoerce . coerce <$> callStaticByteMethod klass method args - SPrim "char" -> unsafeUncoerce . coerce <$> callStaticCharMethod klass method args - SPrim "short" -> unsafeUncoerce . coerce <$> callStaticShortMethod klass method args - SPrim "int" -> unsafeUncoerce . coerce <$> callStaticIntMethod klass method args - SPrim "long" -> unsafeUncoerce . coerce <$> callStaticLongMethod klass method args - SPrim "float" -> unsafeUncoerce . coerce <$> callStaticFloatMethod klass method args - SPrim "double" -> unsafeUncoerce . coerce <$> callStaticDoubleMethod klass method args - SVoid -> do - callStaticVoidMethod klass method args - -- Anything uncoerces to the void type. - return (unsafeUncoerce undefined) - _ -> unsafeUncoerce . coerce <$> callStaticObjectMethod klass method args - --- | Get a static field. -getStaticField - :: forall a ty. (ty ~ Ty a, Coercible a) - => JNI.String -- ^ Class name - -> JNI.String -- ^ Static field name - -> IO a -{-# INLINE getStaticField #-} -getStaticField cname fname = do - let retsing = sing :: Sing ty - klass = unsafeDupablePerformIO $ do - lk <- findClass (referenceTypeName (SClass (JNI.toChars cname))) - gk <- newGlobalRef lk - deleteLocalRef lk - return gk - field = unsafeDupablePerformIO $ getStaticFieldID klass fname (signature retsing) - case retsing of - SPrim "boolean" -> unsafeUncoerce . coerce . w2b <$> getStaticBooleanField klass field - SPrim "byte" -> unsafeUncoerce . coerce <$> getStaticByteField klass field - SPrim "char" -> unsafeUncoerce . coerce <$> getStaticCharField klass field - SPrim "short" -> unsafeUncoerce . coerce <$> getStaticShortField klass field - SPrim "int" -> unsafeUncoerce . coerce <$> getStaticIntField klass field - SPrim "long" -> unsafeUncoerce . coerce <$> getStaticLongField klass field - SPrim "float" -> unsafeUncoerce . coerce <$> getStaticFloatField klass field - SPrim "double" -> unsafeUncoerce . coerce <$> getStaticDoubleField klass field - SVoid -> fail "getStaticField cannot yield an object of type void" - _ -> unsafeUncoerce . coerce <$> getStaticObjectField klass field - where - w2b :: Word8 -> Bool - w2b = toEnum . fromIntegral - --- | Inject a value (of primitive or reference type) to a 'JValue'. This --- datatype is useful for e.g. passing arguments as a list of homogeneous type. --- Synonym for 'coerce'. -jvalue :: (ty ~ Ty a, Coercible a) => a -> JValue -jvalue = coerce - --- | If @ty@ is a reference type, then it should be possible to get an object --- from a value. -jobject :: (ty ~ Ty a, Coercible a, IsReferenceType ty) => a -> J ty -jobject x - | JObject jobj <- coerce x = unsafeCast jobj - | otherwise = error "impossible" - --- | The 'Interp' type family is used by both 'Reify' and 'Reflect'. In order to --- benefit from @-XGeneralizedNewtypeDeriving@ of new instances, we make this an --- /associated/ type family instead of a standalone one. -class (SingI (Interp a), IsReferenceType (Interp a)) => Interpretation (a :: k) where - -- | Map a Haskell type to the symbolic representation of a Java type. - type Interp a :: JType - --- | Extract a concrete Haskell value from the space of Java objects. That is to --- say, unmarshall a Java object to a Haskell value. Unlike coercing, in general --- reifying induces allocations and copies. -class Interpretation a => Reify a where - -- | Invariant: The result and the argument share no direct JVM object - -- references. - reify :: J (Interp a) -> IO a - - default reify :: (Coercible a, Interp a ~ Ty a) => J (Interp a) -> IO a - reify x = unsafeUncoerce . JObject <$> (newLocalRef x :: IO (J (Ty a))) - --- | Inject a concrete Haskell value into the space of Java objects. That is to --- say, marshall a Haskell value to a Java object. Unlike coercing, in general --- reflection induces allocations and copies. -class Interpretation a => Reflect a where - -- | Invariant: The result and the argument share no direct JVM object - -- references. - reflect :: a -> IO (J (Interp a)) - - default reflect :: (Coercible a, Interp a ~ Ty a) => a -> IO (J (Interp a)) - reflect x = newLocalRef (jobject x) - -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) -reifyMVector - :: Storable a - => (JArray ty -> IO (Ptr a)) - -> (JArray ty -> Ptr a -> IO ()) - -> JArray ty - -> IO (IOVector a) -reifyMVector mk finalize jobj0 = do - -- jobj might be finalized before the finalizer of fptr runs. - -- Therefore, we create a global reference without an attached - -- finalizer. - -- See https://ghc.haskell.org/trac/ghc/ticket/13439 - jobj <- newGlobalRefNonFinalized jobj0 - n <- getArrayLength jobj - ptr <- mk jobj - fptr <- newForeignPtr ptr $ finalize jobj ptr - `finally` deleteGlobalRefNonFinalized jobj - return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) - -reflectMVector - :: Storable a - => (Int32 -> IO (JArray ty)) - -> (JArray ty -> Int32 -> Int32 -> Ptr a -> IO ()) - -> IOVector a - -> IO (JArray ty) -reflectMVector newfun fill mv = do - let (fptr, n) = MVector.unsafeToForeignPtr0 mv - jobj <- newfun (fromIntegral n) - withForeignPtr fptr $ fill jobj 0 (fromIntegral n) - return jobj -#endif - -withStatic [d| - instance (SingI ty, IsReferenceType ty) => Interpretation (J ty) where type Interp (J ty) = ty - instance Interpretation (J ty) => Reify (J ty) - instance Interpretation (J ty) => Reflect (J ty) - - -- Ugly work around the fact that java has no equivalent of the 'unit' type: - -- We take an arbitrary serializable type to represent it. - instance Interpretation () where type Interp () = 'Class "java.lang.Short" - instance Reify () where reify _ = return () - instance Reflect () where reflect () = new [JShort 0] - - instance Interpretation ByteString where - type Interp ByteString = 'Array ('Prim "byte") - - instance Reify ByteString where - reify jobj = do - n <- getArrayLength (unsafeCast jobj) - bytes <- getByteArrayElements jobj - -- TODO could use unsafePackCStringLen instead and avoid a copy if we knew - -- that been handed an (immutable) copy via JNI isCopy ref. - bs <- BS.packCStringLen (bytes, fromIntegral n) - releaseByteArrayElements jobj bytes - return bs - - instance Reflect ByteString where - reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do - arr <- newByteArray (fromIntegral n) - setByteArrayRegion arr 0 (fromIntegral n) content - return arr - - instance Interpretation Bool where - type Interp Bool = 'Class "java.lang.Boolean" - - instance Reify Bool where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass - (referenceTypeName (SClass "java.lang.Boolean")) - m <- getMethodID klass "booleanValue" - (methodSignature [] (SPrim "boolean")) - deleteLocalRef klass - return m - callBooleanMethod jobj method [] - - instance Reflect Bool where - reflect x = new [JBoolean (fromIntegral (fromEnum x))] - - instance Interpretation CChar where - type Interp CChar = 'Class "java.lang.Byte" - - instance Reify CChar where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass (referenceTypeName (SClass "java.lang.Byte")) - m <- getMethodID klass "byteValue" - (methodSignature [] (SPrim "byte")) - deleteLocalRef klass - return m - callByteMethod jobj method [] - - instance Reflect CChar where - reflect x = Language.Java.new [JByte x] - - instance Interpretation Int16 where - type Interp Int16 = 'Class "java.lang.Short" - - instance Reify Int16 where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass (referenceTypeName (SClass "java.lang.Short")) - m <- getMethodID klass "shortValue" - (methodSignature [] (SPrim "short")) - deleteLocalRef klass - return m - callShortMethod jobj method [] - - instance Reflect Int16 where - reflect x = new [JShort x] - - instance Interpretation Int32 where - type Interp Int32 = 'Class "java.lang.Integer" - - instance Reify Int32 where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass - (referenceTypeName (SClass "java.lang.Integer")) - m <- getMethodID klass "intValue" - (methodSignature [] (SPrim "int")) - deleteLocalRef klass - return m - callIntMethod jobj method [] - - instance Reflect Int32 where - reflect x = new [JInt x] - - instance Interpretation Int64 where - type Interp Int64 = 'Class "java.lang.Long" - - instance Reify Int64 where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass (referenceTypeName (SClass "java.lang.Long")) - m <- getMethodID klass "longValue" - (methodSignature [] (SPrim "long")) - deleteLocalRef klass - return m - callLongMethod jobj method [] - - instance Reflect Int64 where - reflect x = new [JLong x] - - instance Interpretation Word16 where - type Interp Word16 = 'Class "java.lang.Character" - - instance Reify Word16 where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass - (referenceTypeName (SClass "java.lang.Character")) - m <- getMethodID klass "charValue" - (methodSignature [] (SPrim "char")) - deleteLocalRef klass - return m - fromIntegral <$> callCharMethod jobj method [] - - instance Reflect Word16 where - reflect x = new [JChar x] - - instance Interpretation Double where - type Interp Double = 'Class "java.lang.Double" - - instance Reify Double where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass (referenceTypeName (SClass "java.lang.Double")) - m <- getMethodID klass "doubleValue" - (methodSignature [] (SPrim "double")) - deleteLocalRef klass - return m - callDoubleMethod jobj method [] - - instance Reflect Double where - reflect x = new [JDouble x] - - instance Interpretation Float where - type Interp Float = 'Class "java.lang.Float" - - instance Reify Float where - reify jobj = do - let method = unsafeDupablePerformIO $ do - klass <- findClass (referenceTypeName (SClass "java.lang.Float")) - m <- getMethodID klass "floatValue" - (methodSignature [] (SPrim "float")) - deleteLocalRef klass - return m - callFloatMethod jobj method [] - - instance Reflect Float where - reflect x = new [JFloat x] - - instance Interpretation Text where - type Interp Text = 'Class "java.lang.String" - - instance Reify Text where - reify jobj = do - sz <- getStringLength jobj - cs <- getStringChars jobj - txt <- Text.fromPtr cs (fromIntegral sz) - releaseStringChars jobj cs - return txt - - instance Reflect Text where - reflect x = - Text.useAsPtr x $ \ptr len -> - newString ptr (fromIntegral len) - --- Instances can't be compiled on GHC 8.0.1 due to --- https://ghc.haskell.org/trac/ghc/ticket/12082. -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) - instance Interpretation (IOVector Word16) where - type Interp (IOVector Word16) = 'Array ('Prim "char") - - instance Reify (IOVector Word16) where - reify = reifyMVector getCharArrayElements releaseCharArrayElements - - instance Reflect (IOVector Word16) where - reflect = reflectMVector newCharArray setCharArrayRegion - - instance Interpretation (IOVector Int16) where - type Interp (IOVector Int16) = 'Array ('Prim "short") - - instance Reify (IOVector Int16) where - reify = reifyMVector getShortArrayElements releaseShortArrayElements - - instance Reflect (IOVector Int16) where - reflect = reflectMVector newShortArray setShortArrayRegion - - instance Interpretation (IOVector Int32) where - type Interp (IOVector Int32) = 'Array ('Prim "int") - - instance Reify (IOVector Int32) where - reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements) - - instance Reflect (IOVector Int32) where - reflect = reflectMVector (newIntArray) (setIntArrayRegion) - - instance Interpretation (IOVector Int64) where - type Interp (IOVector Int64) = 'Array ('Prim "long") - - instance Reify (IOVector Int64) where - reify = reifyMVector getLongArrayElements releaseLongArrayElements - - instance Reflect (IOVector Int64) where - reflect = reflectMVector newLongArray setLongArrayRegion - - instance Interpretation (IOVector Float) where - type Interp (IOVector Float) = 'Array ('Prim "float") - - instance Reify (IOVector Float) where - reify = reifyMVector getFloatArrayElements releaseFloatArrayElements - - instance Reflect (IOVector Float) where - reflect = reflectMVector newFloatArray setFloatArrayRegion - - instance Interpretation (IOVector Double) where - type Interp (IOVector Double) = 'Array ('Prim "double") - - instance Reify (IOVector Double) where - reify = reifyMVector (getDoubleArrayElements) (releaseDoubleArrayElements) - - instance Reflect (IOVector Double) where - reflect = reflectMVector (newDoubleArray) (setDoubleArrayRegion) - - instance Interpretation (IOVector a) => Interpretation (Vector a) where - type Interp (Vector a) = Interp (IOVector a) - - instance (Storable a, Reify (IOVector a)) => Reify (Vector a) where - reify = Vector.freeze <=< reify - - instance (Storable a, Reflect (IOVector a)) => Reflect (Vector a) where - reflect = reflect <=< Vector.thaw -#endif - instance Interpretation a => Interpretation [a] where - type Interp [a] = 'Array (Interp a) - - instance Reify a => Reify [a] where - reify jobj = do - n <- getArrayLength jobj - forM [0..n-1] $ \i -> do - jx <- getObjectArrayElement jobj i - x <- reify jx - deleteLocalRef jx - return x - - instance Reflect a => Reflect [a] where - reflect xs = do - let n = fromIntegral (length xs) - array <- newArray n :: IO (J ('Array (Interp a))) - forM_ (zip [0..n-1] xs) $ \(i, x) -> do - jx <- reflect x - setObjectArrayElement array i jx - deleteLocalRef jx - return array - |] diff --git a/src/common/Language/Java.hs b/src/common/Language/Java.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java.hs @@ -0,0 +1,5 @@ +-- | Reexports definitions from "Language.Java.Unsafe". + +module Language.Java (module Language.Java.Unsafe) where + +import Language.Java.Unsafe diff --git a/src/common/Language/Java/Internal.hs b/src/common/Language/Java/Internal.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Internal.hs @@ -0,0 +1,159 @@ +-- | Internal functions to invoke JNI methods +-- +-- The functions in this module avoid using +-- 'Language.Java.Coercible' so they can be reused in interfaces which +-- use other ways to convert between Haskell and Java values. +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Java.Internal + ( newJ + , callToJValue + , callStaticToJValue + , getStaticFieldAsJValue + , getClass + , setGetClassFunction + ) where + +import Data.IORef +import Data.Singletons (SingI(..), SomeSing(..)) +import Foreign.JNI hiding (throw) +import Foreign.JNI.Types +import qualified Foreign.JNI.String as JNI +import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) + +-- | Sets the function to use for loading classes. +-- +-- 'findClass' is used by default. +-- +setGetClassFunction + :: (forall ty. IsReferenceType ty => Sing (ty :: JType) -> IO JClass) + -> IO () +setGetClassFunction f = writeIORef getClassFunctionRef $ GetClassFun f + +-- | Yields a class referece. It behaves as 'findClass' unless +-- 'setGetClassFunction' is used. +getClass :: IsReferenceType ty => Sing (ty :: JType) -> IO JClass +getClass s = readIORef getClassFunctionRef >>= \(GetClassFun f) -> f s + +newtype GetClassFun = + GetClassFun (forall ty. IsReferenceType ty => + Sing (ty :: JType) -> IO JClass + ) + +{-# NOINLINE getClassFunctionRef #-} +getClassFunctionRef :: IORef GetClassFun +getClassFunctionRef = + unsafePerformIO $ newIORef (GetClassFun (findClass . referenceTypeName)) + +newJ + :: forall sym ty. + ( ty ~ 'Class sym + , SingI ty + ) + => [SomeSing JType] -- ^ Singletons of argument types + -> [JValue] + -> IO (J ty) +{-# INLINE newJ #-} +newJ argsings args = do + let voidsing = sing :: Sing 'Void + klass = unsafeDupablePerformIO $ do + lk <- getClass (sing :: Sing ('Class sym)) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + unsafeCast <$> newObject klass (methodSignature argsings voidsing) args + +callToJValue + :: forall ty1 k. (IsReferenceType ty1, SingI ty1) + => Sing (k :: JType) + -> J ty1 -- ^ Any object + -> JNI.String -- ^ Method name + -> [SomeSing JType] -- ^ Singletons of argument types + -> [JValue] -- ^ Arguments + -> IO JValue +{-# INLINE callToJValue #-} +callToJValue retsing obj mname argsings args = do + let klass = unsafeDupablePerformIO $ do + lk <- getClass (sing :: Sing ty1) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + method = unsafeDupablePerformIO $ getMethodID klass mname (methodSignature argsings retsing) + case retsing of + SPrim "boolean" -> JBoolean . fromIntegral . fromEnum <$> + callBooleanMethod obj method args + SPrim "byte" -> JByte <$> callByteMethod obj method args + SPrim "char" -> JChar <$> callCharMethod obj method args + SPrim "short" -> JShort <$> callShortMethod obj method args + SPrim "int" -> JInt <$> callIntMethod obj method args + SPrim "long" -> JLong <$> callLongMethod obj method args + SPrim "float" -> JFloat <$> callFloatMethod obj method args + SPrim "double" -> JDouble <$> callDoubleMethod obj method args + + SVoid -> do + callVoidMethod obj method args + -- The void result is not inspected. + return (error "inspected output of method returning void") + _ -> JObject <$> callObjectMethod obj method args + +callStaticToJValue + :: Sing (k :: JType) + -> JNI.String -- ^ Class name + -> JNI.String -- ^ Method name + -> [SomeSing JType] -- ^ Singletons of argument types + -> [JValue] -- ^ Arguments + -> IO JValue +{-# INLINE callStaticToJValue #-} +callStaticToJValue retsing cname mname argsings args = do + let klass = unsafeDupablePerformIO $ do + lk <- getClass (SClass (JNI.toChars cname)) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + method = unsafeDupablePerformIO $ getStaticMethodID klass mname (methodSignature argsings retsing) + case retsing of + SPrim "boolean" -> JBoolean . fromIntegral . fromEnum <$> + callStaticBooleanMethod klass method args + SPrim "byte" -> JByte <$> callStaticByteMethod klass method args + SPrim "char" -> JChar <$> callStaticCharMethod klass method args + SPrim "short" -> JShort <$> callStaticShortMethod klass method args + SPrim "int" -> JInt <$> callStaticIntMethod klass method args + SPrim "long" -> JLong <$> callStaticLongMethod klass method args + SPrim "float" -> JFloat <$> callStaticFloatMethod klass method args + SPrim "double" -> JDouble <$> callStaticDoubleMethod klass method args + SVoid -> do + callStaticVoidMethod klass method args + -- The void result is not inspected. + return (error "inspected output of method returning void") + _ -> JObject <$> callStaticObjectMethod klass method args + +getStaticFieldAsJValue + :: Sing (ty :: JType) + -> JNI.String -- ^ Class name + -> JNI.String -- ^ Static field name + -> IO JValue +{-# INLINE getStaticFieldAsJValue #-} +getStaticFieldAsJValue retsing cname fname = do + let klass = unsafeDupablePerformIO $ do + lk <- getClass (SClass (JNI.toChars cname)) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + field = unsafeDupablePerformIO $ getStaticFieldID klass fname (signature retsing) + case retsing of + SPrim "boolean" -> JBoolean <$> getStaticBooleanField klass field + SPrim "byte" -> JByte <$> getStaticByteField klass field + SPrim "char" -> JChar <$> getStaticCharField klass field + SPrim "short" -> JShort <$> getStaticShortField klass field + SPrim "int" -> JInt <$> getStaticIntField klass field + SPrim "long" -> JLong <$> getStaticLongField klass field + SPrim "float" -> JFloat <$> getStaticFloatField klass field + SPrim "double" -> JDouble <$> getStaticDoubleField klass field + SVoid -> fail "getStaticField cannot yield an object of type void" + _ -> JObject <$> getStaticObjectField klass field diff --git a/src/common/Language/Java/Unsafe.hs b/src/common/Language/Java/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/common/Language/Java/Unsafe.hs @@ -0,0 +1,858 @@ +-- | High-level helper functions for interacting with Java objects, mapping them +-- to Haskell values and vice versa. The 'Reify' and 'Reflect' classes together +-- are to Java what "Foreign.Storable" is to C: they provide a means to +-- marshall/unmarshall Java objects from/to Haskell data types. +-- +-- A typical pattern for wrapping Java API's using this module is: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE DeriveAnyClass \#-} +-- module Object where +-- +-- import Language.Java.Unsafe as J +-- +-- newtype Object = Object ('J' (''Class' "java.lang.Object")) +-- deriving (J.Coercible, J.Interpretation, J.Reify, J.Reflect) +-- +-- clone :: Object -> IO Object +-- clone obj = J.'call' obj "clone" [] +-- +-- equals :: Object -> Object -> IO Bool +-- equals obj1 obj2 = J.'call' obj1 "equals" ['jvalue' obj2] +-- +-- ... +-- @ +-- +-- To call Java methods using quasiquoted Java syntax instead, see +-- "Language.Java.Inline". +-- +-- The functions in this module are considered unsafe, as opposed to those in +-- "Language.Java.Safe", which guarantee that local references are not leaked. +-- Functions with a 'VariadicIO' constraint in their context are variadic, +-- meaning that you can apply them to any number of arguments, provided they are +-- 'Coercible'. +-- +-- __NOTE 1:__ To use any function in this module, you'll need an initialized +-- JVM in the current process, using 'withJVM' or otherwise. +-- +-- __NOTE 2:__ Functions in this module memoize (cache) any implicitly performed +-- class and method lookups, for performance. This memoization is safe only when +-- no new named classes are defined at runtime. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Language.Java.Unsafe + ( module Foreign.JNI.Types + -- * JVM instance management + , withJVM + -- * JVM calls + , classOf + , getClass + , setGetClassFunction + , new + , newArray + , toArray + , call + , callStatic + , getStaticField + , VariadicIO + -- * Reference management + , push + , pushWithSizeHint + , Pop(..) + , pop + , popWithObject + , popWithValue + , withLocalRef + -- * Coercions + , CoercionFailure(..) + , Coercible(..) + , jvalue + , jobject + -- * Conversions + , Interpretation(..) + , Reify(..) + , Reflect(..) + , Nullable(..) + , pattern Null + , pattern NotNull + , W8Bool(..) + -- * Re-exports + , sing + ) where + +import Control.Distributed.Closure.TH +import Control.Exception (Exception, throw, finally) +import Control.Monad +import Control.Monad.Catch (MonadCatch, MonadMask, bracket, onException) +import Control.Monad.IO.Class +import Data.Char (chr, ord) +import qualified Data.Choice as Choice +import qualified Data.Coerce as Coerce +import Data.Constraint (Dict(..)) +import Data.Int +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable, TypeRep, typeOf) +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Kind (Type) +import Data.Singletons (SingI(..), SomeSing(..)) +import qualified Data.Text.Foreign as Text +import Data.Text (Text) +import qualified Data.Vector.Storable as Vector +import Data.Vector.Storable (Vector) +import qualified Data.Vector.Storable.Mutable as MVector +import Data.Vector.Storable.Mutable (IOVector) +import Foreign (Ptr, Storable, withForeignPtr) +import Foreign.Concurrent (newForeignPtr) +import Foreign.C (CChar) +import Foreign.JNI hiding (throw) +import Foreign.JNI.Types +import qualified Foreign.JNI.String as JNI +import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) +import qualified GHC.TypeLits as TypeError (ErrorMessage(..)) +import Language.Java.Internal +import System.IO.Unsafe (unsafeDupablePerformIO) + +data Pop a where + PopValue :: a -> Pop a + PopObject + :: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty) + => a + -> Pop a + +-- | Open a new scope for allocating (JNI) local references to JVM objects. +push :: (MonadCatch m, MonadIO m) => m (Pop a) -> m a +push = pushWithSizeHint 4 + +-- | Like 'push', but specify explicitly a minimum size for the frame. You +-- probably don't need this. +pushWithSizeHint :: forall a m. (MonadCatch m, MonadIO m) => Int32 -> m (Pop a) -> m a +pushWithSizeHint capacity m = do + liftIO $ pushLocalFrame capacity + m `onException` handler >>= \case + PopValue x -> do + _ <- liftIO $ popLocalFrame jnull + return x + PopObject x -> do + liftIO $ Coerce.coerce <$> popLocalFrame (jobject x) + where + handler = liftIO $ popLocalFrame jnull + +-- | Equivalent to 'popWithValue ()'. +pop :: Monad m => m (Pop ()) +pop = return (PopValue ()) + +-- | Pop a frame and return a JVM object. +popWithObject + :: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty, Monad m) + => a + -> m (Pop a) +popWithObject x = return (PopObject x) + +-- | Pop a frame and return a value. This value MUST NOT be an object reference +-- created in the popped frame. In that case use 'popWithObject' instead. +popWithValue :: Monad m => a -> m (Pop a) +popWithValue x = return (PopValue x) + +-- | Create a local ref and delete it when the given action completes. +withLocalRef + :: (MonadMask m, MonadIO m, Coerce.Coercible o (J ty)) + => m o -> (o -> m a) -> m a +withLocalRef m = bracket m (liftIO . deleteLocalRef) + +-- Note [Class lookup memoization] +-- +-- By using unsafeDupablePerformIO, we mark the lookup actions as pure. When the +-- body of the function is inlined within the calling context, the lookups +-- typically become closed expressions, therefore are CAF's that can be floated +-- to top-level by the GHC optimizer. + +-- | Tag data types that can be coerced in O(1) time without copy to a Java +-- object or primitive type (i.e. have the same representation) by declaring an +-- instance of this type class for that data type. +class SingI (Ty a) => Coercible a where + type Ty a :: JType + coerce :: a -> JValue + unsafeUncoerce :: JValue -> a + + default coerce + :: Coerce.Coercible a (J (Ty a)) + => a + -> JValue + coerce x = JObject (Coerce.coerce x :: J (Ty a)) + + default unsafeUncoerce + :: Coerce.Coercible (J (Ty a)) a + => JValue + -> a + unsafeUncoerce (JObject obj) = Coerce.coerce (unsafeCast obj :: J (Ty a)) + unsafeUncoerce _ = + error "Cannot unsafeUncoerce: object expected but value of primitive type found." + +-- | The identity instance. +instance SingI ty => Coercible (J ty) where + type Ty (J ty) = ty + +-- | A JNI call may cause a (Java) exception to be raised. This module raises it +-- as a Haskell exception wrapping the Java exception. +data CoercionFailure = CoercionFailure + { coercionActual :: JValue + , coercionExpected :: TypeRep + } + +instance Exception CoercionFailure + +instance Show CoercionFailure where + show (CoercionFailure actual expected) = + "Can't coerce " ++ show actual ++ " to " ++ show expected ++ "." + +withTypeRep :: Typeable a => (TypeRep -> a) -> a +withTypeRep f = let x = f (typeOf x) in x + +instance Coercible Bool where + type Ty Bool = 'Prim "boolean" + coerce x = JBoolean (fromIntegral (fromEnum x)) + unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x) + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible CChar where + type Ty CChar = 'Prim "byte" + coerce = JByte + unsafeUncoerce (JByte x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Char where + type Ty Char = 'Prim "char" + coerce x = JChar (fromIntegral (ord x)) + unsafeUncoerce (JChar x) = chr (fromIntegral x) + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Word16 where + type Ty Word16 = 'Prim "char" + coerce = JChar + unsafeUncoerce (JChar x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Int16 where + type Ty Int16 = 'Prim "short" + coerce = JShort + unsafeUncoerce (JShort x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Int32 where + type Ty Int32 = 'Prim "int" + coerce = JInt + unsafeUncoerce (JInt x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Int64 where + type Ty Int64 = 'Prim "long" + coerce = JLong + unsafeUncoerce (JLong x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Float where + type Ty Float = 'Prim "float" + coerce = JFloat + unsafeUncoerce (JFloat x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible Double where + type Ty Double = 'Prim "double" + coerce = JDouble + unsafeUncoerce (JDouble x) = x + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) +instance Coercible () where + type Ty () = 'Void + coerce = error "Void value undefined." + unsafeUncoerce _ = () +instance Coercible (Choice.Choice a) where + type Ty (Choice.Choice a) = 'Prim "boolean" + coerce = coerce . Choice.toBool + unsafeUncoerce = Choice.fromBool . unsafeUncoerce + +-- | Inject a value (of primitive or reference type) to a 'JValue'. This +-- datatype is useful for e.g. passing arguments as a list of homogeneous type. +-- Synonym for 'coerce'. +jvalue :: (ty ~ Ty a, Coercible a) => a -> JValue +jvalue = coerce + +-- | If @ty@ is a reference type, then it should be possible to get an object +-- from a value. +jobject :: (ty ~ Ty a, Coercible a, IsReferenceType ty) => a -> J ty +jobject x + | JObject jobj <- coerce x = unsafeCast jobj + | otherwise = error "impossible" + +-- | Get the Java class of an object or anything 'Coercible' to one. +classOf + :: forall a sym. (Ty a ~ 'Class sym, Coercible a, KnownSymbol sym) + => a + -> JNI.String +classOf x = JNI.fromChars (symbolVal (Proxy :: Proxy sym)) `const` coerce x + +-- | @VariadicIO_ f@ constraints @f@ to be of the form +-- +-- > f :: a₁ -> ... -> aₙ -> IO b +-- +-- for any value of @n@, where the context provides +-- +-- > (Coercible a₁, ... , Coercible aₙ) +-- +class VariadicIO_ f where + -- | The singletons of the argument types of @f@. + -- + -- > sings (Proxy (a₁ -> ... -> aₙ -> IO b) = + -- > [SomeSing (sing @a₁), ... , SomeSing (sing @aₙ)] + -- + sings :: Proxy f -> [SomeSing JType] + + -- | @apply g a₁ ... aₙ = g [coerce a₁, ... , coerce aₙ]@ + apply :: ([JValue] -> IO (ReturnTypeIO f)) -> f + +-- | The return type of a variadic function +-- +-- In general, +-- +-- > ReturnTypeIO (a₁ -> ... -> aₙ -> IO b) = b +-- +-- We keep it as a standalone type family to enable +-- the definition of the catch-all @VariadicIO_ x@ instance. +type family ReturnTypeIO f :: Data.Kind.Type + +-- | Document that a function is variadic +-- +-- @VariadicIO f b@ constraints @f@ to be of the form +-- +-- > a₁ -> ... -> aₙ -> IO b +-- +-- for any value of @n@, where the context provides +-- +-- > (Coercible a₁, ... , Coercible aₙ) +-- +type VariadicIO f b = (ReturnTypeIO f ~ b, VariadicIO_ f) + +type instance ReturnTypeIO (IO a) = a + +instance VariadicIO_ (IO a) where + sings _ = [] + apply f = f [] + +type instance ReturnTypeIO (a -> f) = ReturnTypeIO f + +instance (Coercible a, VariadicIO_ f) => VariadicIO_ (a -> f) where + sings _ = SomeSing (sing @(Ty a)) : sings @f Proxy + apply f x = apply (\xs -> f (coerce x : xs)) + +-- All errors of the form "Could not deduce (VariadicIO_ x) from ..." +-- are replaced with the following type error. +instance + {-# OVERLAPPABLE #-} + TypeError (TypeError.Text "Expected: a₁ -> ... -> aₙ -> IO b" TypeError.:$$: + TypeError.Text "Actual: " TypeError.:<>: TypeError.ShowType x) => + VariadicIO_ x where + sings = undefined + apply = undefined + +-- | Creates a new instance of the class whose name is resolved from the return +-- type. For instance, +-- +-- @ +-- do x :: 'J' (''Class' "java.lang.Integer") <- new 42 +-- return x +-- @ +-- +-- You can pass any number of 'Coercible' arguments to the constructor. +new + :: forall a f sym. + ( Ty a ~ 'Class sym + , Coerce.Coercible a (J ('Class sym)) + , Coercible a + , VariadicIO f a + ) => f +{-# INLINE new #-} +new = apply $ \args -> Coerce.coerce <$> newJ @sym (sings @f Proxy) args + +-- | Creates a new Java array of the given size. The type of the elements +-- of the resulting array is determined by the return type a call to +-- 'newArray' has, at the call site, and must not be left ambiguous. +-- +-- To create a Java array of 50 booleans: +-- +-- @ +-- do arr :: 'J' (''Array' (''Prim' "boolean")) <- 'newArray' 50 +-- return arr +-- @ +newArray :: forall ty. SingI ty => Int32 -> IO (J ('Array ty)) +{-# INLINE newArray #-} +newArray sz = do + let tysing = sing @ty + case tysing of + SPrim "boolean" -> unsafeCast <$> newBooleanArray sz + SPrim "byte" -> unsafeCast <$> newByteArray sz + SPrim "char" -> unsafeCast <$> newCharArray sz + SPrim "short" -> unsafeCast <$> newShortArray sz + SPrim "int" -> unsafeCast <$> newIntArray sz + SPrim "long" -> unsafeCast <$> newLongArray sz + SPrim "float" -> unsafeCast <$> newFloatArray sz + SPrim "double" -> unsafeCast <$> newDoubleArray sz + SVoid -> fail "newArray of void" + _ -> case singToIsReferenceType tysing of + Nothing -> fail $ "newArray of " ++ show tysing + Just Dict -> do + let klass = unsafeDupablePerformIO $ do + lk <- getClass tysing + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + unsafeCast <$> newObjectArray sz klass + +-- | Creates an array from a list of references. +toArray + :: forall ty. (SingI ty, IsReferenceType ty) + => [J ty] + -> IO (J ('Array ty)) +toArray xs = do + let n = fromIntegral (length xs) + jxs <- newArray n + zipWithM_ (setObjectArrayElement jxs) [0 .. n - 1] xs + return jxs + +-- | The Swiss Army knife for calling Java methods. Give it an object or any +-- data type coercible to one and any number of 'Coercible' arguments. Based on +-- the types of each argument, and based on the return type, 'call' will invoke +-- the named method using of the @call*Method@ family of functions in the JNI +-- API. +-- +-- When the method name is overloaded, use 'upcast' or 'unsafeCast' +-- appropriately on the class instance and/or on the arguments to invoke the +-- right method. +-- +-- Example: +-- +-- @ +-- call obj "frobnicate" x y z +-- @ +call + :: forall a b ty f. + ( VariadicIO f b + , ty ~ Ty a + , IsReferenceType ty + , Coercible a + , Coercible b + , Coerce.Coercible a (J ty) + ) + => a + -> JNI.String + -> f +call obj mname = apply $ \args -> + unsafeUncoerce <$> + callToJValue + (sing @(Ty b)) + (Coerce.coerce obj :: J ty) + mname + (sings @f Proxy) + args + +-- | Same as 'call', but for static methods. +-- +-- Example: +-- +-- @ +-- callStatic "java.lang.Integer" "parseInt" jstr +-- @ +callStatic + :: forall a ty f. + (ty ~ Ty a, Coercible a, VariadicIO f a) + => JNI.String -- ^ Class name + -> JNI.String -- ^ Method name + -> f +{-# INLINE callStatic #-} +callStatic cname mname = apply $ \args -> + unsafeUncoerce <$> + callStaticToJValue (sing @ty) cname mname (sings @f Proxy) args + +-- | Get a static field. +getStaticField + :: forall a ty. (ty ~ Ty a, Coercible a) + => JNI.String -- ^ Class name + -> JNI.String -- ^ Static field name + -> IO a +{-# INLINE getStaticField #-} +getStaticField cname fname = + unsafeUncoerce <$> getStaticFieldAsJValue (sing @ty) cname fname + +-- | The 'Interp' type family is used by both 'Reify' and 'Reflect'. In order to +-- benefit from @-XGeneralizedNewtypeDeriving@ of new instances, we make this an +-- /associated/ type family instead of a standalone one. +class (SingI (Interp a), IsReferenceType (Interp a)) => Interpretation (a :: k) where + -- | Map a Haskell type to the symbolic representation of a Java type. + type Interp a :: JType + +-- | Extract a concrete Haskell value from the space of Java objects. That is to +-- say, unmarshall a Java object to a Haskell value. Unlike coercing, in general +-- reifying induces allocations and copies. +class Interpretation a => Reify a where + -- | Invariant: The result and the argument share no direct JVM object + -- references. + reify :: J (Interp a) -> IO a + + default reify :: (Coercible a, Interp a ~ Ty a) => J (Interp a) -> IO a + reify x = unsafeUncoerce . JObject <$> (newLocalRef x :: IO (J (Ty a))) + +-- | Inject a concrete Haskell value into the space of Java objects. That is to +-- say, marshall a Haskell value to a Java object. Unlike coercing, in general +-- reflection induces allocations and copies. +class Interpretation a => Reflect a where + -- | Invariant: The result and the argument share no direct JVM object + -- references. + reflect :: a -> IO (J (Interp a)) + + default reflect :: (Coercible a, Interp a ~ Ty a) => a -> IO (J (Interp a)) + reflect x = newLocalRef (jobject x) + +-- | A newtype wrapper for representing Java values that can be null +newtype Nullable a = Nullable (Maybe a) + deriving (Eq, Ord, Show) + +pattern Null :: Nullable a +pattern Null <- Nullable Nothing where + Null = Nullable Nothing + +pattern NotNull :: a -> Nullable a +pattern NotNull a <- Nullable (Just a) where + NotNull a = Nullable (Just a) + +reifyMVector + :: Storable a + => (JArray ty -> IO (Ptr a)) + -> (JArray ty -> Ptr a -> IO ()) + -> JArray ty + -> IO (IOVector a) +reifyMVector mk finalize jobj0 = do + -- jobj might be finalized before the finalizer of fptr runs. + -- Therefore, we create a global reference without an attached + -- finalizer. + -- See https://ghc.haskell.org/trac/ghc/ticket/13439 + jobj <- newGlobalRefNonFinalized jobj0 + n <- getArrayLength jobj + ptr <- mk jobj + fptr <- newForeignPtr ptr $ submitToFinalizerThread $ + finalize jobj ptr `finally` deleteGlobalRefNonFinalized jobj + return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) + +reflectMVector + :: Storable a + => (Int32 -> IO (JArray ty)) + -> (JArray ty -> Int32 -> Int32 -> Ptr a -> IO ()) + -> IOVector a + -> IO (JArray ty) +reflectMVector newfun fill mv = do + let (fptr, n) = MVector.unsafeToForeignPtr0 mv + jobj <- newfun (fromIntegral n) + withForeignPtr fptr $ fill jobj 0 (fromIntegral n) + return jobj + +withStatic [d| + instance (SingI ty, IsReferenceType ty) => Interpretation (J ty) where type Interp (J ty) = ty + instance Interpretation (J ty) => Reify (J ty) + instance Interpretation (J ty) => Reflect (J ty) + + -- Ugly work around the fact that java has no equivalent of the 'unit' type: + -- We take an arbitrary serializable type to represent it. + instance Interpretation () where type Interp () = 'Class "java.lang.Short" + instance Reify () where reify _ = return () + instance Reflect () where reflect () = new (0 :: Int16) + + instance Interpretation ByteString where + type Interp ByteString = 'Array ('Prim "byte") + + instance Reify ByteString where + reify jobj = do + n <- getArrayLength (unsafeCast jobj) + bytes <- getByteArrayElements jobj + -- TODO could use unsafePackCStringLen instead and avoid a copy if we knew + -- that been handed an (immutable) copy via JNI isCopy ref. + bs <- BS.packCStringLen (bytes, fromIntegral n) + releaseByteArrayElements jobj bytes + return bs + + instance Reflect ByteString where + reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do + arr <- newByteArray (fromIntegral n) + setByteArrayRegion arr 0 (fromIntegral n) content + return arr + + instance Interpretation Bool where + type Interp Bool = 'Class "java.lang.Boolean" + + instance Reify Bool where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Boolean") + m <- getMethodID klass "booleanValue" + (methodSignature [] (SPrim "boolean")) + deleteLocalRef klass + return m + callBooleanMethod jobj method [] + + instance Reflect Bool where + reflect = new + + instance Interpretation CChar where + type Interp CChar = 'Class "java.lang.Byte" + + instance Reify CChar where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Byte") + m <- getMethodID klass "byteValue" + (methodSignature [] (SPrim "byte")) + deleteLocalRef klass + return m + callByteMethod jobj method [] + + instance Reflect CChar where + reflect = Language.Java.Unsafe.new + + instance Interpretation Int16 where + type Interp Int16 = 'Class "java.lang.Short" + + instance Reify Int16 where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Short") + m <- getMethodID klass "shortValue" + (methodSignature [] (SPrim "short")) + deleteLocalRef klass + return m + callShortMethod jobj method [] + + instance Reflect Int16 where + reflect = new + + instance Interpretation Int32 where + type Interp Int32 = 'Class "java.lang.Integer" + + instance Reify Int32 where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Integer") + m <- getMethodID klass "intValue" + (methodSignature [] (SPrim "int")) + deleteLocalRef klass + return m + callIntMethod jobj method [] + + instance Reflect Int32 where + reflect = new + + instance Interpretation Int64 where + type Interp Int64 = 'Class "java.lang.Long" + + instance Reify Int64 where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Long") + m <- getMethodID klass "longValue" + (methodSignature [] (SPrim "long")) + deleteLocalRef klass + return m + callLongMethod jobj method [] + + instance Reflect Int64 where + reflect = new + + instance Interpretation Word16 where + type Interp Word16 = 'Class "java.lang.Character" + + instance Reify Word16 where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Character") + m <- getMethodID klass "charValue" + (methodSignature [] (SPrim "char")) + deleteLocalRef klass + return m + fromIntegral <$> callCharMethod jobj method [] + + instance Reflect Word16 where + reflect = new + + instance Interpretation Double where + type Interp Double = 'Class "java.lang.Double" + + instance Reify Double where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Double") + m <- getMethodID klass "doubleValue" + (methodSignature [] (SPrim "double")) + deleteLocalRef klass + return m + callDoubleMethod jobj method [] + + instance Reflect Double where + reflect = new + + instance Interpretation Float where + type Interp Float = 'Class "java.lang.Float" + + instance Reify Float where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- getClass (SClass "java.lang.Float") + m <- getMethodID klass "floatValue" + (methodSignature [] (SPrim "float")) + deleteLocalRef klass + return m + callFloatMethod jobj method [] + + instance Reflect Float where + reflect = new + + instance Interpretation a => Interpretation (Nullable a) where + type Interp (Nullable a) = Interp a + + instance Reify a => Reify (Nullable a) where + reify jobj = if jobj == jnull then return Null else NotNull <$> reify jobj + + instance Reflect a => Reflect (Nullable a) where + reflect Null = return jnull + reflect (NotNull a) = reflect a + + instance Interpretation Text where + type Interp Text = 'Class "java.lang.String" + + instance Reify Text where + reify jobj = do + sz <- getStringLength jobj + cs <- getStringChars jobj + txt <- Text.fromPtr cs (fromIntegral sz) + releaseStringChars jobj cs + return txt + + instance Reflect Text where + reflect x = + Text.useAsPtr x $ \ptr len -> + newString ptr (fromIntegral len) + + newtype W8Bool = W8Bool { fromW8Bool :: Word8 } + deriving (Enum, Eq, Integral, Num, Ord, Real, Show, Storable) + + instance Interpretation (IOVector W8Bool) where + type Interp (IOVector W8Bool) = 'Array ('Prim "boolean") + + instance Reify (IOVector W8Bool) where + reify = fmap (Coerce.coerce :: IOVector Word8 -> IOVector W8Bool) . + reifyMVector getBooleanArrayElements releaseBooleanArrayElements + + instance Reflect (IOVector W8Bool) where + reflect = reflectMVector newBooleanArray setBooleanArrayRegion . + (Coerce.coerce :: IOVector W8Bool -> IOVector Word8) + + instance Interpretation (IOVector Word16) where + type Interp (IOVector Word16) = 'Array ('Prim "char") + + instance Reify (IOVector Word16) where + reify = reifyMVector getCharArrayElements releaseCharArrayElements + + instance Reflect (IOVector Word16) where + reflect = reflectMVector newCharArray setCharArrayRegion + + instance Interpretation (IOVector Int16) where + type Interp (IOVector Int16) = 'Array ('Prim "short") + + instance Reify (IOVector Int16) where + reify = reifyMVector getShortArrayElements releaseShortArrayElements + + instance Reflect (IOVector Int16) where + reflect = reflectMVector newShortArray setShortArrayRegion + + instance Interpretation (IOVector Int32) where + type Interp (IOVector Int32) = 'Array ('Prim "int") + + instance Reify (IOVector Int32) where + reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements) + + instance Reflect (IOVector Int32) where + reflect = reflectMVector (newIntArray) (setIntArrayRegion) + + instance Interpretation (IOVector Int64) where + type Interp (IOVector Int64) = 'Array ('Prim "long") + + instance Reify (IOVector Int64) where + reify = reifyMVector getLongArrayElements releaseLongArrayElements + + instance Reflect (IOVector Int64) where + reflect = reflectMVector newLongArray setLongArrayRegion + + instance Interpretation (IOVector Float) where + type Interp (IOVector Float) = 'Array ('Prim "float") + + instance Reify (IOVector Float) where + reify = reifyMVector getFloatArrayElements releaseFloatArrayElements + + instance Reflect (IOVector Float) where + reflect = reflectMVector newFloatArray setFloatArrayRegion + + instance Interpretation (IOVector Double) where + type Interp (IOVector Double) = 'Array ('Prim "double") + + instance Reify (IOVector Double) where + reify = reifyMVector (getDoubleArrayElements) (releaseDoubleArrayElements) + + instance Reflect (IOVector Double) where + reflect = reflectMVector (newDoubleArray) (setDoubleArrayRegion) + + instance Interpretation (IOVector a) => Interpretation (Vector a) where + type Interp (Vector a) = Interp (IOVector a) + + instance (Storable a, Reify (IOVector a)) => Reify (Vector a) where + reify = Vector.freeze <=< reify + + instance (Storable a, Reflect (IOVector a)) => Reflect (Vector a) where + reflect = reflect <=< Vector.thaw + + instance Interpretation a => Interpretation [a] where + type Interp [a] = 'Array (Interp a) + + instance Reify a => Reify [a] where + reify jobj = do + n <- getArrayLength jobj + forM [0..n-1] $ \i -> do + jx <- getObjectArrayElement jobj i + x <- reify jx + deleteLocalRef jx + return x + + instance Reflect a => Reflect [a] where + reflect xs = do + let n = fromIntegral (length xs) + array <- newArray n :: IO (J ('Array (Interp a))) + forM_ (zip [0..n-1] xs) $ \(i, x) -> do + jx <- reflect x + setObjectArrayElement array i jx + deleteLocalRef jx + return array + |] diff --git a/src/linear-types/Language/Java/Safe.hs b/src/linear-types/Language/Java/Safe.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Language/Java/Safe.hs @@ -0,0 +1,586 @@ +-- | A linear interface for functions in Language.Java +-- +-- These are high-level helper functions for interacting with Java objects, +-- mapping them to Haskell values and vice versa. The 'Reify' and 'Reflect' +-- classes together are to Java what "Foreign.Storable" is to C: they +-- provide a means to marshall/unmarshall Java objects from/to Haskell data +-- types. +-- +-- A typical pattern for wrapping Java API's using this module is: +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE DeriveAnyClass \#-} +-- module Object where +-- +-- import Language.Java.Safe as J +-- +-- newtype Object = Object ('J' (''Class' "java.lang.Object")) +-- deriving (J.Coercible, J.Interpretation, J.Reify, J.Reflect) +-- +-- clone :: Object #-> Linear.IO Object +-- clone obj = J.'call' obj "clone" End +-- +-- equals :: Object #-> Object #-> Linear.IO Bool +-- equals obj1 obj2 = J.'call' obj1 "equals" obj2 End +-- +-- ... +-- @ +-- +-- To call Java methods using quasiquoted Java syntax instead, see +-- "Language.Java.Inline.Safe". +-- +-- __NOTE 1:__ To use any function in this module, you'll need an initialized +-- JVM in the current process, using 'withJVM' or otherwise. +-- +-- __NOTE 2:__ Functions in this module memoize (cache) any implicitly performed +-- class and method lookups, for performance. This memoization is safe only when +-- no new named classes are defined at runtime. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Language.Java.Safe + ( module Foreign.JNI.Types.Safe + -- * JVM instance management + , withJVM + -- * JVM calls + , classOf + , new + , newArray + , toArray + , call + , callStatic + , getStaticField + , End(..) + , Variadic + -- * Coercions + , Coercible(..) + , jvalue + , jobject + -- * Conversions + , Interpretation(..) + , Reify(..) + , Reflect(..) + , reify_ + -- * Re-exports + , sing + ) where + +import Control.Exception (evaluate) +import Control.Monad.IO.Class.Linear (MonadIO) +import Control.Monad.Linear hiding ((<$>)) +import Data.ByteString (ByteString) +import qualified Data.Choice as Choice +import qualified Data.Coerce as Coerce +import Data.Kind (Type) +import Data.Int +import Data.Singletons (SingI(..), SomeSing(..)) +import Data.Text (Text) +import Data.Typeable +import qualified Data.Unrestricted.Linear as Unrestricted +import Data.Vector.Storable (Vector) +import Data.Vector.Storable.Mutable (IOVector) +import Data.Word +import Foreign.C (CChar) +import qualified Foreign.JNI as JNI +import Foreign.JNI.Safe +import Foreign.JNI.Types.Safe +import qualified Foreign.JNI.String as JNI +import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) +import qualified GHC.TypeLits as TypeError (ErrorMessage(..)) + +import qualified Language.Java as Java +import qualified Language.Java.Internal as Java +import Prelude ((.), (-)) +import qualified Prelude +import Prelude.Linear hiding ((.)) +import qualified Unsafe.Linear as Unsafe + + +-- | A linear variant of "Java.Coercible". +-- +-- All types that wrap tracked references can implement +-- an instance of this class. +class SingI (Ty a) => Coercible a where + type Ty a :: JType + coerce :: a #-> JValue + unsafeUncoerce :: JValue #-> a + + default coerce + :: Coerce.Coercible a (J (Ty a)) + => a + #-> JValue + coerce x = JObject (Unsafe.toLinear Coerce.coerce x :: J (Ty a)) + + default unsafeUncoerce + :: Coerce.Coercible (J (Ty a)) a + => JValue + #-> a + unsafeUncoerce = Unsafe.toLinear $ \case + JObject obj -> Coerce.coerce (unsafeCast obj :: J (Ty a)) + v -> error Prelude.$ + "Cannot unsafeUncoerce: object expected but value of primitive type found.: " + ++ show v + +instance SingI ty => Coercible (J ty) where + type Ty (J ty) = ty + +withTypeRep :: Typeable a => (TypeRep -> a) -> a +withTypeRep f = let x = f (typeOf x) in x + +coercePrim :: Java.Coercible a => a #-> JValue +coercePrim x = JValue (Unsafe.toLinear Java.coerce x) + +unsafeUncoercePrim :: (Typeable a, Java.Coercible a) => JValue #-> a +unsafeUncoercePrim = Unsafe.toLinear $ \case + JValue v -> Java.unsafeUncoerce v + val -> withTypeRep + (\r -> error ("unsafeUncoercePrim can't uncoerce a reference: " + ++ show (val, r) + ) + ) + +instance Coercible Bool where + type Ty Bool = Java.Ty Bool + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible CChar where + type Ty CChar = Java.Ty CChar + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Char where + type Ty Char = Java.Ty Char + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Word16 where + type Ty Word16 = Java.Ty Word16 + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Int16 where + type Ty Int16 = Java.Ty Int16 + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Int32 where + type Ty Int32 = Java.Ty Int32 + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Int64 where + type Ty Int64 = Java.Ty Int64 + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Float where + type Ty Float = Java.Ty Float + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible Double where + type Ty Double = Java.Ty Double + coerce = coercePrim + unsafeUncoerce = unsafeUncoercePrim +instance Coercible () where + type Ty () = Java.Ty () + coerce = error "Void value undefined." + unsafeUncoerce = Unsafe.toLinear (const ()) +instance Coercible (Choice.Choice a) where + type Ty (Choice.Choice a) = Java.Ty Bool + coerce c = coerce (Unsafe.toLinear Choice.toBool c) + unsafeUncoerce v = Unsafe.toLinear Choice.fromBool (unsafeUncoerce v) + +instance (IsPrimitiveType (Ty a), Java.Coercible a, Typeable a) + => Coercible (Unrestricted a) where + type Ty (Unrestricted a) = Java.Ty a + coerce (Unrestricted a) = JValue (Java.coerce a) + unsafeUncoerce = Unsafe.toLinear $ \v -> + Unsafe.toLinear (Unrestricted $!) (unsafeUncoercePrim v) + +instance (IsReferenceType (Java.Ty a), Java.Coercible a, Typeable a) + => Coercible (UnsafeUnrestrictedReference a) where + type Ty (UnsafeUnrestrictedReference a) = Java.Ty a + coerce (UnsafeUnrestrictedReference a) = JValue (Java.coerce a) + unsafeUncoerce = Unsafe.toLinear $ \case + JObject j -> + UnsafeUnrestrictedReference (Java.unsafeUncoerce (Java.JObject (unJ j))) + v -> withTypeRep + (\r -> error ("unsafeUncoerce: unexpected primitive type for: " + ++ show (v, r) + ) + ) + +-- | Get the Java class of an object or anything 'Coercible' to one. +classOf + :: forall a sym. (Ty a ~ 'Class sym, Coercible a, KnownSymbol sym) + => a + #-> (a, JNI.String) +classOf = Unsafe.toLinear $ \x -> (,) x $ + JNI.fromChars (symbolVal (Proxy :: Proxy sym)) `const` coerce x + +-- | A sentinel value to end the list of arguments in variadic +-- functions +data End = End + +-- | @Variadic_ f@ constraints @f@ to be of the form +-- +-- > f :: a₁ #-> ... #-> aₙ #-> End -> ReturnType f +-- +-- for any value of @n@, where the context provides +-- +-- > (Coercible a₁, ... , Coercible aₙ) +-- +class Variadic_ f where + -- | The singletons of the argument types of @f@. + -- + -- > sings (Proxy (a₁ #-> ... #-> aₙ #-> End -> r) = + -- > [SomeSing (sing @a₁), ... , SomeSing (sing @aₙ)] + -- + sings :: Proxy f -> [SomeSing JType] + + -- | @apply g a₁ ... aₙ End = g [coerce a₁, ... , coerce aₙ]@ + apply :: ([JValue] #-> ReturnType f) #-> f + +instance Variadic_ (End -> r) where + sings _ = [] + apply f End = f [] + +instance (Coercible a, Variadic_ f) => Variadic_ (a #-> f) where + sings _ = SomeSing (sing @(Ty a)) : sings @f Proxy + apply f x = apply (\xs -> f (coerce x : xs)) + +-- All errors of the form "Could not deduce (Variadic_ x) from ..." +-- are replaced with the following type error. +instance + {-# OVERLAPPABLE #-} + TypeError ('TypeError.Text "Expected: a₁ #-> ... #-> aₙ #-> End -> r" 'TypeError.:$$: + 'TypeError.Text "Actual: " 'TypeError.:<>: 'TypeError.ShowType x) => + Variadic_ x where + sings = undefined + apply = undefined + +-- | The return type of a variadic function +-- +-- In general, +-- +-- > ReturnType (a₁ #-> ... #-> aₙ #-> End -> r) = r +-- +-- We keep it as a standalone type family to enable +-- the definition of the catch-all @Variadic_ x@ instance. +type family ReturnType f :: Data.Kind.Type where + ReturnType (End -> r) = r + ReturnType (a #-> f) = ReturnType f + +-- | @VariadicIO f b@ constraints @f@ to be of the form +-- +-- > a₁ #-> ... #-> aₙ #-> End -> IO b +-- +-- for any value of @n@, where the context provides +-- +-- > (Coercible a₁, ... , Coercible aₙ) +-- +type Variadic f r = (ReturnType f ~ r, Variadic_ f) + +-- | Creates a new instance of the class whose name is resolved from the return +-- type. For instance, +-- +-- @ +-- do x :: 'J' (''Class' "java.lang.Integer") <- new (42 :: Int32) End +-- return x +-- @ +new + :: forall a sym m f. + (Ty a ~ 'Class sym, Coercible a, MonadIO m, Variadic f (m a)) + => f +{-# INLINE new #-} +new = apply $ + Unsafe.toLinear $ \args -> fmap unsafeUncoerce $ liftPreludeIO Prelude.$ do + JObject . J <$> Java.newJ @sym (sings @f Proxy) (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +-- | Creates a new Java array of the given size. The type of the elements +-- of the resulting array is determined by the return type a call to +-- 'newArray' has, at the call site, and must not be left ambiguous. +-- +-- To create a Java array of 50 booleans: +-- +-- @ +-- do arr :: 'J' (''Array' (''Prim' "boolean")) <- 'newArray' 50 +-- return arr +-- @ +newArray :: (MonadIO m, SingI ty) => Int32 -> m (J ('Array ty)) +{-# INLINE newArray #-} +newArray sz = liftPreludeIO (J <$> Java.newArray sz) + +-- | Creates an array from a list of references. +toArray + :: (SingI ty, IsReferenceType ty, MonadIO m) + => [J ty] + #-> m ([J ty], J ('Array ty)) +toArray = Unsafe.toLinear $ \xs -> + liftPreludeIO ((,) xs . J <$> Java.toArray (Coerce.coerce xs)) + +-- | The Swiss Army knife for calling Java methods. Give it an object or +-- any data type coercible to one, the name of a method, and a list of +-- arguments. Based on the type indexes of each argument, and based on the +-- return type, 'call' will invoke the named method using of the @call*Method@ +-- family of functions in the JNI API. +-- +-- When the method name is overloaded, use 'upcast' or 'unsafeCast' +-- appropriately on the class instance and/or on the arguments to invoke the +-- right method. +call + :: forall a b ty1 ty2 m f. + ( ty1 ~ Ty a + , ty2 ~ Ty b + , IsReferenceType ty1 + , Coercible a + , Coercible b + , Coerce.Coercible a (J ty1) + , MonadIO m + , Variadic f (m b) + ) + => a -- ^ Any object or value 'Coercible' to one + #-> JNI.String -- ^ Method name + -> f +{-# INLINE call #-} +call = Unsafe.toLinear $ \obj mname -> apply $ Unsafe.toLinear $ \args -> do + liftPreludeIO Prelude.$ strictUnsafeUncoerce Prelude.$ do + fromJNIJValue <$> + Java.callToJValue + @ty1 + (sing @ty1) + (Coerce.coerce obj) + mname + (sings @f Proxy) + (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +strictUnsafeUncoerce :: Coercible a => IO JValue -> IO a +strictUnsafeUncoerce m = m Prelude.>>= \x -> evaluate (unsafeUncoerce x) + +fromJNIJValue :: Java.JValue -> JValue +fromJNIJValue = \case + Java.JObject j -> JObject (J j) + v -> JValue v + +-- | Same as 'call', but for static methods. +callStatic + :: forall a ty m f. (ty ~ Ty a, Coercible a, MonadIO m, Variadic f (m a)) + => JNI.String -- ^ Class name + -> JNI.String -- ^ Method name + -> f +{-# INLINE callStatic #-} +callStatic cname mname = apply $ Unsafe.toLinear $ \args -> do + liftPreludeIO Prelude.$ strictUnsafeUncoerce Prelude.$ + fromJNIJValue <$> + Java.callStaticToJValue + (sing @ty) + cname mname + (sings @f Proxy) + (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +-- | Get a static field. +getStaticField + :: forall a ty m. (ty ~ Ty a, Coercible a, MonadIO m) + => JNI.String -- ^ Class name + -> JNI.String -- ^ Static field name + -> m a +getStaticField cname fname = + liftPreludeIO Prelude.$ strictUnsafeUncoerce Prelude.$ + fromJNIJValue <$> + Java.getStaticFieldAsJValue (sing @ty) cname fname + +-- | Inject a value (of primitive or reference type) to a 'JValue'. This +-- datatype is useful for e.g. passing arguments as a list of homogeneous type. +-- Synonym for 'coerce'. +jvalue :: (ty ~ Ty a, Coercible a) => a #-> JValue +jvalue = coerce + +-- | If @ty@ is a reference type, then it should be possible to get an object +-- from a value. +jobject :: (ty ~ Ty a, Coercible a, IsReferenceType ty) => a #-> J ty +jobject = Unsafe.toLinear $ \x -> + case coerce x of + JObject jobj -> unsafeCast jobj + _ -> error "impossible" + +-- | The 'Interp' type family is used by both 'Reify' and 'Reflect'. In order to +-- benefit from @-XGeneralizedNewtypeDeriving@ of new instances, we make this an +-- /associated/ type family instead of a standalone one. +class (SingI (Interp a), IsReferenceType (Interp a)) => Interpretation (a :: k) where + -- | Map a Haskell type to the symbolic representation of a Java type. + type Interp a :: JType + +-- | Extract a concrete Haskell value from the space of Java objects. That is to +-- say, unmarshall a Java object to a Haskell value. Unlike coercing, in general +-- reifying induces allocations and copies. +class Interpretation a => Reify a where + -- | Invariant: The result and the argument share no direct JVM object + -- references. + reify :: MonadIO m => J (Interp a) #-> m (J (Interp a), Unrestricted a) + + default reify + :: (Java.Coercible a, Interp a ~ Java.Ty a, MonadIO m) + => J (Interp a) + #-> m (J (Interp a), Unrestricted a) + reify = Unsafe.toLinear $ \x -> fmap ((,) x) $ + liftPreludeIOU Prelude.$ + Java.unsafeUncoerce . Java.JObject <$> JNI.newLocalRef (unJ x) + +reify_ :: (Reify a, MonadIO m) => J (Interp a) #-> m (Unrestricted a) +reify_ _j = reify _j >>= \(_j, a) -> a <$ deleteLocalRef _j + +-- | Inject a concrete Haskell value into the space of Java objects. That is to +-- say, marshall a Haskell value to a Java object. Unlike coercing, in general +-- reflection induces allocations and copies. +class Interpretation a => Reflect a where + -- | Invariant: The result and the argument share no direct JVM object + -- references. + reflect :: MonadIO m => a -> m (J (Interp a)) + + default reflect + :: (Java.Coercible a, Interp a ~ Java.Ty a, MonadIO m) + => a + -> m (J (Interp a)) + reflect x = liftPreludeIO (J <$> JNI.newLocalRef (Java.jobject x)) + +instance (SingI ty, IsReferenceType ty) => Interpretation (Java.J ty) where type Interp (Java.J ty) = ty +instance Interpretation (Java.J ty) => Reify (Java.J ty) +instance Interpretation (Java.J ty) => Reflect (Java.J ty) + +javaReify + :: (Java.Interp a ~ Interp a, Java.Reify a, MonadIO m) + => J (Interp a) + #-> m (J (Interp a), Unrestricted a) +javaReify = Unsafe.toLinear $ \j -> + liftPreludeIO ((,) j . Unrestricted <$> Java.reify (unJ j)) + +javaReflect + :: (Java.Interp a ~ Interp a, Java.Reflect a, MonadIO m) + => a + -> m (J (Interp a)) +javaReflect a = fmap J $ liftPreludeIO (Java.reflect a) + +instance Interpretation () where type Interp () = Java.Interp () +instance Reify () where reify = javaReify +instance Reflect () where reflect = javaReflect + +instance Interpretation ByteString where type Interp ByteString = Java.Interp ByteString +instance Reify ByteString where reify = javaReify +instance Reflect ByteString where reflect = javaReflect + +instance Interpretation Bool where type Interp Bool = Java.Interp Bool +instance Reify Bool where reify = javaReify +instance Reflect Bool where reflect = javaReflect + +instance Interpretation CChar where type Interp CChar = Java.Interp CChar +instance Reify CChar where reify = javaReify +instance Reflect CChar where reflect = javaReflect + +instance Interpretation Int16 where type Interp Int16 = Java.Interp Int16 +instance Reify Int16 where reify = javaReify +instance Reflect Int16 where reflect = javaReflect + +instance Interpretation Word16 where type Interp Word16 = Java.Interp Word16 +instance Reify Word16 where reify = javaReify +instance Reflect Word16 where reflect = javaReflect + +instance Interpretation Int32 where type Interp Int32 = Java.Interp Int32 +instance Reify Int32 where reify = javaReify +instance Reflect Int32 where reflect = javaReflect + +instance Interpretation Int64 where type Interp Int64 = Java.Interp Int64 +instance Reify Int64 where reify = javaReify +instance Reflect Int64 where reflect = javaReflect + +instance Interpretation Float where type Interp Float = Java.Interp Float +instance Reify Float where reify = javaReify +instance Reflect Float where reflect = javaReflect + +instance Interpretation Double where type Interp Double = Java.Interp Double +instance Reify Double where reify = javaReify +instance Reflect Double where reflect = javaReflect + +instance Interpretation Text where type Interp Text = Java.Interp Text +instance Reify Text where reify = javaReify +instance Reflect Text where reflect = javaReflect + +instance Interpretation (IOVector Word16) where + type Interp (IOVector Word16) = Java.Interp (IOVector Word16) +instance Reify (IOVector Word16) where reify = javaReify +instance Reflect (IOVector Word16) where reflect = javaReflect + +instance Interpretation (IOVector Int16) where + type Interp (IOVector Int16) = Java.Interp (IOVector Int16) +instance Reify (IOVector Int16) where reify = javaReify +instance Reflect (IOVector Int16) where reflect = javaReflect + +instance Interpretation (IOVector Int32) where + type Interp (IOVector Int32) = Java.Interp (IOVector Int32) +instance Reify (IOVector Int32) where reify = javaReify +instance Reflect (IOVector Int32) where reflect = javaReflect + +instance Interpretation (IOVector Int64) where + type Interp (IOVector Int64) = Java.Interp (IOVector Int64) +instance Reify (IOVector Int64) where reify = javaReify +instance Reflect (IOVector Int64) where reflect = javaReflect + +instance Interpretation (IOVector Float) where + type Interp (IOVector Float) = Java.Interp (IOVector Float) +instance Reify (IOVector Float) where reify = javaReify +instance Reflect (IOVector Float) where reflect = javaReflect + +instance Interpretation (IOVector Double) where + type Interp (IOVector Double) = Java.Interp (IOVector Double) +instance Reify (IOVector Double) where reify = javaReify +instance Reflect (IOVector Double) where reflect = javaReflect + +instance (SingI (Interp (Vector a)), IsReferenceType (Interp (Vector a))) + => Interpretation (Vector a) where + type Interp (Vector a) = Java.Interp (Vector a) +instance Java.Reify (Vector a) => Reify (Vector a) where + reify = javaReify +instance Java.Reflect (Vector a) => Reflect (Vector a) where + reflect = javaReflect + +instance Interpretation a => Interpretation [a] where + type Interp [a] = 'Array (Interp a) + +instance Reify a => Reify [a] where + reify _jobj = + getArrayLength _jobj >>= \(_jobj, Unrestricted n) -> + foldM + (\(_jobj, uxs) i -> + getObjectArrayElement _jobj i >>= \(_jobj, jx) -> + reify_ jx >>= \ux -> + return (_jobj, Unrestricted.lift2 (:) ux uxs) + ) + (_jobj, Unrestricted []) [n Prelude.- 1, n Prelude.- 2..0] + +instance Reflect a => Reflect [a] where + reflect xs = + let n = fromIntegral (length xs) + in newArray n >>= \array -> + foldM + (\array0 (Unrestricted (i, x)) -> + reflect x >>= \jx -> + setObjectArrayElement_ array0 i jx + ) + array (map Unrestricted (zip [0..n Prelude.- 1] xs)) diff --git a/tests/Language/JavaSpec.hs b/tests/Language/JavaSpec.hs --- a/tests/Language/JavaSpec.hs +++ b/tests/Language/JavaSpec.hs @@ -7,24 +7,31 @@ module Language.JavaSpec where +import Control.Concurrent (runInBoundThread) +import Control.Monad (join) import Data.Int import qualified Data.Text as Text -import Data.Text (Text) -import Foreign.JNI (getArrayLength) +import Data.Text (Text, isInfixOf) +import Data.Text.Arbitrary () +import Data.Text.Encoding (encodeUtf8) +import Foreign.JNI (getArrayLength, runInAttachedThread) +import qualified Foreign.JNI.String as JNI import Language.Java import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck spec :: Spec -spec = do +spec = around_ (runInBoundThread . runInAttachedThread) $ do describe "callStatic" $ do it "can call double-returning static functions" $ do jstr <- reflect ("1.2345" :: Text) - callStatic "java.lang.Double" "parseDouble" [coerce jstr] + callStatic "java.lang.Double" "parseDouble" jstr `shouldReturn` (1.2345 :: Double) it "can call int-returning static functions" $ do jstr <- reflect ("12345" :: Text) - callStatic "java.lang.Integer" "parseInt" [coerce jstr] + callStatic "java.lang.Integer" "parseInt" jstr `shouldReturn` (12345 :: Int32) it "can call String-returning static functions" $ do @@ -32,7 +39,8 @@ callStatic "java.lang.Integer" "toString" - [coerce (12345 :: Int32)] + + (12345 :: Int32) reify jstr `shouldReturn` ("12345" :: Text) it "can get static fields" $ do @@ -42,31 +50,31 @@ it "can get enum values" $ do monday :: J ('Class "java.time.DayOfWeek") <- getStaticField "java.time.DayOfWeek" "MONDAY" - call monday "getValue" [] + call monday "getValue" `shouldReturn` (1 :: Int32) it "short doesn't under- or overflow" $ do maxshort <- reflect (Text.pack (show (maxBound :: Int16))) minshort <- reflect (Text.pack (show (minBound :: Int16))) - callStatic "java.lang.Short" "parseShort" [coerce maxshort] + callStatic "java.lang.Short" "parseShort" maxshort `shouldReturn` (maxBound :: Int16) - callStatic "java.lang.Short" "parseShort" [coerce minshort] + callStatic "java.lang.Short" "parseShort" minshort `shouldReturn` (minBound :: Int16) it "int doesn't under- or overflow" $ do maxint <- reflect (Text.pack (show (maxBound :: Int32))) minint <- reflect (Text.pack (show (minBound :: Int32))) - callStatic "java.lang.Integer" "parseInt" [coerce maxint] + callStatic "java.lang.Integer" "parseInt" maxint `shouldReturn` (maxBound :: Int32) - callStatic "java.lang.Integer" "parseInt" [coerce minint] + callStatic "java.lang.Integer" "parseInt" minint `shouldReturn` (minBound :: Int32) it "long doesn't under- or overflow" $ do maxlong <- reflect (Text.pack (show (maxBound :: Int64))) minlong <- reflect (Text.pack (show (minBound :: Int64))) - callStatic "java.lang.Long" "parseLong" [coerce maxlong] + callStatic "java.lang.Long" "parseLong" maxlong `shouldReturn` (maxBound :: Int64) - callStatic "java.lang.Long" "parseLong" [coerce minlong] + callStatic "java.lang.Long" "parseLong" minlong `shouldReturn` (minBound :: Int64) describe "newArray" $ do @@ -86,5 +94,38 @@ -- Applications need extra conversions if the following doesn't hold. it "can get Integer when Long is expected" $ do let i = maxBound :: Int32 - j <- new [coerce i] :: IO (J ('Class "java.lang.Integer")) + j <- new i :: IO (J ('Class "java.lang.Integer")) reify (unsafeCast j) `shouldReturn` (fromIntegral i :: Int64) + + it "correctly encodes characters outside ASCII range" $ do + let incorrect :: Text = "आपकी उम्र लंबी हो और आप समृद्ध बने 👋" + let correct = Text.replace "👋" "🖖" incorrect + hello <- reflect ("👋" :: Text) + spock <- reflect ("🖖" :: Text) + jincorrect <- reflect incorrect + jcorrect :: JString <- call jincorrect "replaceFirst" hello spock + reify jcorrect `shouldReturn` correct + + describe "strings" $ do + -- It is known that the current implementation of JNI.String does not support embedded NULL + prop "correctly convert back and forth from Prelude.String to JNI.String" $ + \s -> (notElem '\NUL' s) ==> (s === (JNI.toChars . JNI.fromChars) s) + prop "correctly convert back and forth from JNI.String to Prelude.String" $ + \t -> (not $ isInfixOf "\NUL" t) ==> + let s = JNI.fromByteString $ encodeUtf8 t + in s === (JNI.fromChars . JNI.toChars) s + + prop "correctly convert back and forth from Data.Text to java.lang.String" $ + \(textBefore :: Text) -> ioProperty $ do + withLocalRef (reflect textBefore) $ \jTextBefore -> + -- call substring() to force returning a new object + withLocalRef (call jTextBefore "substring" (0 :: Int32)) $ \(jTextAfter :: JString) -> do + textAfter :: Text <- reify jTextAfter + return $ textBefore === textAfter + + prop "correctly convert back and forth from java.lang.String to Data.Text" $ + \(textBefore :: Text) -> ioProperty $ do + withLocalRef (reflect textBefore) $ \jTextBefore -> + withLocalRef (join $ (reflect . Text.copy) <$> reify jTextBefore) $ \jTextAfter -> do + isEqual :: Bool <- call jTextBefore "equals" (upcast jTextAfter) + return $ isEqual === True diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,1 +1,2 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -F -pgmF HSPEC_DISCOVER -optF --module-name=Spec #-}