jvm 0.4.2 → 0.6.0
raw patch · 10 files changed
Files
- README.md +5/−4
- benchmarks/Main.hs +197/−28
- jvm.cabal +26/−6
- src/Language/Java.hs +0/−793
- src/common/Language/Java.hs +5/−0
- src/common/Language/Java/Internal.hs +159/−0
- src/common/Language/Java/Unsafe.hs +858/−0
- src/linear-types/Language/Java/Safe.hs +586/−0
- tests/Language/JavaSpec.hs +55/−14
- tests/Spec.hs +2/−1
README.md view
@@ -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
benchmarks/Main.hs view
@@ -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+ ]
jvm.cabal view
@@ -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
− src/Language/Java.hs
@@ -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- |]
+ src/common/Language/Java.hs view
@@ -0,0 +1,5 @@+-- | Reexports definitions from "Language.Java.Unsafe".++module Language.Java (module Language.Java.Unsafe) where++import Language.Java.Unsafe
+ src/common/Language/Java/Internal.hs view
@@ -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
+ src/common/Language/Java/Unsafe.hs view
@@ -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+ |]
+ src/linear-types/Language/Java/Safe.hs view
@@ -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))
tests/Language/JavaSpec.hs view
@@ -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
tests/Spec.hs view
@@ -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 #-}