jvm 0.2.2 → 0.3.0
raw patch · 5 files changed
+438/−215 lines, 5 filesdep +constraintsdep +deepseqdep +exceptionsdep −template-haskelldep ~jnidep ~singletons
Dependencies added: constraints, deepseq, exceptions
Dependencies removed: template-haskell
Dependency ranges changed: jni, singletons
Files
- benchmarks/Main.hs +58/−13
- jvm.cabal +8/−5
- src/Language/Java.hs +330/−142
- src/Language/Java/TH.hs +0/−46
- tests/Language/JavaSpec.hs +42/−9
benchmarks/Main.hs view
@@ -6,17 +6,30 @@ module Main where +import Control.DeepSeq (NFData(..))+import Criterion.Main as Criterion import Data.Int-import Language.Java+import Data.Singletons (SomeSing(..))+import qualified Foreign.Concurrent as Concurrent+import qualified Foreign.ForeignPtr as ForeignPtr import Foreign.JNI-import Criterion.Main as Criterion+import Foreign.Marshal.Alloc (mallocBytes, finalizerFree)+import Language.Java -incrementExact :: Int32 -> IO Int32-incrementExact x = callStatic (sing :: Sing "java.lang.Math") "incrementExact" [coerce x]+newtype BoxObject = BoxObject JObject+newtype BoxClass = BoxClass JClass -jniIncrementExact :: JClass -> JMethodID -> Int32 -> IO Int32-jniIncrementExact klass method x = callStaticIntMethod klass method [coerce x]+-- 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` () +jabs :: Int32 -> IO Int32+jabs x = callStatic "java.lang.Math" "abs" [coerce x]++jniAbs :: JClass -> JMethodID -> Int32 -> IO Int32+jniAbs klass method x = callStaticIntMethod klass method [coerce x]+ intValue :: Int32 -> IO Int32 intValue x = do jx <- reflect x@@ -33,14 +46,13 @@ foreign import ccall unsafe getpid :: IO Int -main :: IO ()-main = withJVM [] $ do- klass <- findClass "java/lang/Math"- method <- getStaticMethodID klass "incrementExact" "(I)I"- Criterion.defaultMain+benchCalls :: Benchmark+benchCalls =+ env ini $ \ ~(BoxClass klass, method) ->+ bgroup "Calls" [ bgroup "Java calls"- [ bench "static method call: unboxed single arg / unboxed return" $ nfIO $ incrementExact 1- , bench "jni static method call: unboxed single arg / unboxed return" $ nfIO $ jniIncrementExact klass method 1+ [ bench "static method call: unboxed single arg / unboxed return" $ nfIO $ jabs 1+ , 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 ]@@ -49,3 +61,36 @@ , bench "ffi haskell" $ nfIO $ getpid ] ]+ where+ 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)++benchRefs :: Benchmark+benchRefs =+ env (BoxObject <$> new []) $ \ ~(BoxObject jobj) ->+ bgroup "References"+ [ bench "local reference" $ nfIO $ do+ _ <- newLocalRef jobj+ return ()+ , bench "global reference" $ nfIO $ do+ _ <- newGlobalRef jobj+ return ()+ , bench "global reference (no finalizer)" $ nfIO $ do+ _ <- newGlobalRefNonFinalized jobj+ return ()+ , bench "Foreign.Concurrent.newForeignPtr" $ nfIO $ do+ _ <- Concurrent.newForeignPtr (unsafeObjectToPtr jobj) (return ())+ return ()+ , bench "Foreign.ForeignPtr.newForeignPtr" $ nfIO $ do+ -- Approximate cost of malloc: 50ns. Ideally would move out of benchmark+ -- but finalizer not idempotent.+ ptr <- mallocBytes 4+ _ <- ForeignPtr.newForeignPtr finalizerFree ptr+ return ()+ ]++main :: IO ()+main = withJVM [] $ do+ Criterion.defaultMain [benchCalls, benchRefs]
jvm.cabal view
@@ -1,5 +1,5 @@ name: jvm-version: 0.2.2+version: 0.3.0 synopsis: Call JVM methods from Haskell. description: Please see README.md. homepage: http://github.com/tweag/inline-java/tree/master/jvm#readme@@ -22,15 +22,15 @@ hs-source-dirs: src exposed-modules: Language.Java- Language.Java.TH build-depends: base >= 4.7 && < 5, bytestring >=0.10,+ constraints >= 0.8, choice >= 0.1, distributed-closure >=0.3,- jni >= 0.3.0,+ exceptions >= 0.8,+ jni >= 0.4.0, singletons >= 2.0,- template-haskell >= 2.10, text >=1.2, vector >=0.11 default-language: Haskell2010@@ -47,6 +47,7 @@ base, bytestring, hspec,+ jni, jvm, text default-language: Haskell2010@@ -59,7 +60,9 @@ build-depends: base >= 4.8 && < 5, criterion,+ deepseq >= 1.4.2, jni,- jvm+ jvm,+ singletons default-language: Haskell2010 ghc-options: -threaded
src/Language/Java.hs view
@@ -39,60 +39,122 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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- , jvalue+ , getStaticField+ -- * Reference management+ , push+ , pushWithSizeHint+ , Pop(..)+ , pop+ , popWithObject+ , popWithValue+ -- * Coercions+ , CoercionFailure(..) , Coercible(..)+ , jvalue+ , jobject+ -- * Conversions , Reify(..) , Reflect(..)- , Type(..)- , Uncurry , Interp+ -- * Re-exports , sing ) where -import Control.Distributed.Closure import Control.Distributed.Closure.TH+import Control.Exception (Exception, throw, finally) import Control.Monad+import Control.Monad.Catch (MonadCatch, 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(..), fromSing)-import Data.String (fromString)+import Data.Singletons (SingI(..)) import qualified Data.Text.Foreign as Text import Data.Text (Text)-#if ! __GLASGOW_HASKELL__ == 800+#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 (FunPtr, Ptr, Storable, newForeignPtr, withForeignPtr)+import Foreign (Ptr, Storable, withForeignPtr)+import Foreign.Concurrent (newForeignPtr) #endif import Foreign.C (CChar)-import Foreign.JNI+import Foreign.JNI hiding (throw) import Foreign.JNI.Types import qualified Foreign.JNI.String as JNI-import GHC.TypeLits (KnownSymbol, Symbol)+import GHC.TypeLits (KnownSymbol, symbolVal) import System.IO.Unsafe (unsafeDupablePerformIO) +data Pop a where+ PopValue :: a -> Pop a+ PopObject+ :: (Coercible a ty, 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+ :: (Coercible a ty, 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)+ -- Note [Class lookup memoization] -- -- By using unsafeDupablePerformIO, we mark the lookup actions as pure. When the@@ -124,42 +186,58 @@ -- | The identity instance. instance SingI ty => Coercible (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 ('Prim "boolean") where coerce x = JBoolean (fromIntegral (fromEnum x)) unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x)- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible CChar ('Prim "byte") where coerce = JByte unsafeUncoerce (JByte x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Char ('Prim "char") where coerce x = JChar (fromIntegral (ord x)) unsafeUncoerce (JChar x) = chr (fromIntegral x)- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Word16 ('Prim "char") where coerce = JChar unsafeUncoerce (JChar x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int16 ('Prim "short") where coerce = JShort unsafeUncoerce (JShort x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int32 ('Prim "int") where coerce = JInt unsafeUncoerce (JInt x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int64 ('Prim "long") where coerce = JLong unsafeUncoerce (JLong x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Float ('Prim "float") where coerce = JFloat unsafeUncoerce (JFloat x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Double ('Prim "double") where coerce = JDouble unsafeUncoerce (JDouble x) = x- unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type."+ unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible () 'Void where coerce = error "Void value undefined." unsafeUncoerce _ = ()@@ -168,14 +246,8 @@ unsafeUncoerce = Choice.fromBool . unsafeUncoerce -- | Get the Java class of an object or anything 'Coercible' to one.-classOf- :: ( Coercible a ('Class sym)- , KnownSymbol sym- )- => a- -> Sing sym--- Silence redundant constraint warning.-classOf x = sing `const` coerce x+classOf :: forall a sym. (Coercible a ('Class sym), 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,@@ -195,11 +267,62 @@ new args = do let argsings = map jtypeOf args voidsing = sing :: Sing 'Void- klass = unsafeDupablePerformIO $- findClass (referenceTypeName (sing :: Sing ('Class sym)))- >>= newGlobalRef+ 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@@ -219,9 +342,11 @@ call obj mname args = do let argsings = map jtypeOf args retsing = sing :: Sing ty2- klass = unsafeDupablePerformIO $- findClass (referenceTypeName (sing :: Sing ty1))- >>= newGlobalRef+ 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@@ -239,14 +364,22 @@ _ -> unsafeUncoerce . coerce <$> callObjectMethod obj method args -- | Same as 'call', but for static methods.-callStatic :: forall a ty sym. Coercible a ty => Sing (sym :: Symbol) -> JNI.String -> [JValue] -> IO a+callStatic+ :: forall a ty. Coercible a ty+ => 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 $- findClass (referenceTypeName (SClass (fromString (fromSing cname))))- >>= newGlobalRef+ 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@@ -263,43 +396,49 @@ return (unsafeUncoerce undefined) _ -> unsafeUncoerce . coerce <$> callStaticObjectMethod klass method args +-- | Get a static field.+getStaticField+ :: forall a ty. Coercible a ty+ => JNI.String -- ^ Class name+ -> JNI.String -- ^ Static field name+ -> IO a+{-# INLINE getStaticField #-}+getStaticField cname fname = do+ let retsing = sing :: Sing ty+ klass = unsafeDupablePerformIO $+ findClass (referenceTypeName (SClass (JNI.toChars cname)))+ >>= newGlobalRef+ 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 :: Coercible a ty => a -> JValue jvalue = coerce --- | Classifies Java types according to whether they are base types (data) or--- higher-order types (objects representing functions).-data Type a- = Fun [Type a] (Type a) -- ^ Pure function- | Act [Type a] (Type a) -- ^ IO action- | Proc [Type a] -- ^ Procedure (i.e void returning action)- | Base a -- ^ Any first-order type.---- | Haskell functions are curried, but Java functions are not. This type family--- maps Haskell types to an uncurried (non-inductive) type representation,--- useful to select the right 'Reify' / 'Reflect' instance without overlap.-type family Uncurry (a :: *) :: Type * where- Uncurry (Closure (a -> b -> c -> d -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c, Uncurry d]- Uncurry (Closure (a -> b -> c -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c]- Uncurry (Closure (a -> b -> IO ())) = 'Proc '[Uncurry a, Uncurry b]- Uncurry (Closure (a -> IO ())) = 'Proc '[Uncurry a]- Uncurry (IO ()) = 'Proc '[]- Uncurry (Closure (a -> b -> c -> d -> IO e)) = 'Act '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e)- Uncurry (Closure (a -> b -> c -> IO d)) = 'Act '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d)- Uncurry (Closure (a -> b -> IO c)) = 'Act '[Uncurry a, Uncurry b] (Uncurry c)- Uncurry (Closure (a -> IO b)) = 'Act '[Uncurry a] (Uncurry b)- Uncurry (Closure (IO a)) = 'Act '[] (Uncurry a)- Uncurry (Closure (a -> b -> c -> d -> e)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e)- Uncurry (Closure (a -> b -> c -> d)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d)- Uncurry (Closure (a -> b -> c)) = 'Fun '[Uncurry a, Uncurry b] (Uncurry c)- Uncurry (Closure (a -> b)) = 'Fun '[Uncurry a] (Uncurry b)- Uncurry a = 'Base a+-- | If @ty@ is a reference type, then it should be possible to get an object+-- from a value.+jobject :: (Coercible a ty, IsReferenceType ty) => a -> J ty+jobject x+ | JObject jobj <- coerce x = unsafeCast jobj+ | otherwise = error "impossible" -- | Map a Haskell type to the symbolic representation of a Java type. type family Interp (a :: k) :: JType-type instance Interp ('Base a) = Interp a -- | 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@@ -308,35 +447,49 @@ -- Instances of this class /must/ guarantee that the result is managed on the -- Haskell heap. That is, the Haskell runtime has /global ownership/ of the -- result.-class (Interp (Uncurry a) ~ ty, SingI ty, IsReferenceType ty)- => Reify a ty where- reify :: J ty -> IO a+--+-- WARNING: The default method just creates a global reference to the Java+-- object. Widespread use of this mechanism can cause memory problems since+-- objects in the Java heap cause no pressure on the Haskell garbage collector.+-- If the Haskell's GC is not executed by the time the Java heap is full, the+-- Java code might sporadically fail with OutOfMemory exceptions.+--+class (SingI (Interp a), IsReferenceType (Interp a))+ => Reify a where+ reify :: J (Interp a) -> IO a + default reify :: Coercible a (Interp a) => J (Interp a) -> IO a+ reify x = (unsafeUncoerce . JObject) <$> newGlobalRef x+ -- | 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. -- -- Instances of this class /must not/ claim global ownership.-class (Interp (Uncurry a) ~ ty, SingI ty, IsReferenceType ty)- => Reflect a ty where- reflect :: a -> IO (J ty)+class (SingI (Interp a), IsReferenceType (Interp a))+ => Reflect a where+ reflect :: a -> IO (J (Interp a)) -#if ! __GLASGOW_HASKELL__ == 800-foreign import ccall "wrapper" wrapFinalizer- :: (Ptr a -> IO ())- -> IO (FunPtr (Ptr a -> IO ()))+ default reflect :: Coercible a (Interp 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 jobj = do+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- ffinalize <- wrapFinalizer (finalize jobj)- fptr <- newForeignPtr ffinalize ptr+ fptr <- newForeignPtr ptr $ finalize jobj ptr+ `finally` deleteGlobalRefNonFinalized jobj return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) reflectMVector@@ -353,31 +506,17 @@ #endif withStatic [d|- type instance Interp (J ty) = ty-- -- Use this instance to claim global ownership of a Java object on the- -- Haskell heap until the Haskell garbage collector determines that it is- -- inaccessible. Objects that need to survive the dynamic scope delimited by- -- the topmost Java frame on the call stack must have global ownership.- instance (SingI ty, IsReferenceType ty) => Reify (J ty) ty where- reify x = newGlobalRef x-- -- Use this instance to relinquish global ownership of a Java object. You- -- /must not/ refer to the argument anywhere after a call to 'reflect'.- instance (SingI ty, IsReferenceType ty) => Reflect (J ty) ty where- reflect x = newLocalRef x- type instance Interp () = 'Class "java.lang.Object" - instance Reify () ('Class "java.lang.Object") where+ instance Reify () where reify _ = return () - instance Reflect () ('Class "java.lang.Object") where+ instance Reflect () where reflect () = new [] type instance Interp ByteString = 'Array ('Prim "byte") - instance Reify ByteString ('Array ('Prim "byte")) where+ instance Reify ByteString where reify jobj = do n <- getArrayLength (unsafeCast jobj) bytes <- getByteArrayElements jobj@@ -387,7 +526,7 @@ releaseByteArrayElements jobj bytes return bs - instance Reflect ByteString ('Array ('Prim "byte")) where+ instance Reflect ByteString where reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do arr <- newByteArray (fromIntegral n) setByteArrayRegion arr 0 (fromIntegral n) content@@ -395,84 +534,130 @@ type instance Interp Bool = 'Class "java.lang.Boolean" - instance Reify Bool ('Class "java.lang.Boolean") where+ instance Reify Bool where reify jobj = do- klass <- findClass "java/lang/Boolean"- method <- getMethodID klass "booleanValue" "()Z"+ 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 ('Class "java.lang.Boolean") where+ instance Reflect Bool where reflect x = new [JBoolean (fromIntegral (fromEnum x))] + type instance 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]+ type instance Interp Int16 = 'Class "java.lang.Short" - instance Reify Int16 ('Class "java.lang.Short") where+ instance Reify Int16 where reify jobj = do- klass <- findClass "java/lang/Short"- method <- getMethodID klass "shortValue" "()S"+ 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 ('Class "java.lang.Short") where+ instance Reflect Int16 where reflect x = new [JShort x] type instance Interp Int32 = 'Class "java.lang.Integer" - instance Reify Int32 ('Class "java.lang.Integer") where+ instance Reify Int32 where reify jobj = do- klass <- findClass "java/lang/Integer"- method <- getMethodID klass "intValue" "()I"+ 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 ('Class "java.lang.Integer") where+ instance Reflect Int32 where reflect x = new [JInt x] type instance Interp Int64 = 'Class "java.lang.Long" - instance Reify Int64 ('Class "java.lang.Long") where+ instance Reify Int64 where reify jobj = do- klass <- findClass "java/lang/Long"- method <- getMethodID klass "longValue" "()J"+ 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 ('Class "java.lang.Long") where+ instance Reflect Int64 where reflect x = new [JLong x] type instance Interp Word16 = 'Class "java.lang.Character" - instance Reify Word16 ('Class "java.lang.Character") where+ instance Reify Word16 where reify jobj = do- klass <- findClass "java/lang/Character"- method <- getMethodID klass "charValue" "()C"+ 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 ('Class "java.lang.Character") where+ instance Reflect Word16 where reflect x = new [JChar x] type instance Interp Double = 'Class "java.lang.Double" - instance Reify Double ('Class "java.lang.Double") where+ instance Reify Double where reify jobj = do- klass <- findClass "java/lang/Double"- method <- getMethodID klass "doubleValue" "()D"+ 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 ('Class "java.lang.Double") where+ instance Reflect Double where reflect x = new [JDouble x] type instance Interp Float = 'Class "java.lang.Float" - instance Reify Float ('Class "java.lang.Float") where+ instance Reify Float where reify jobj = do- klass <- findClass "java/lang/Float"- method <- getMethodID klass "floatValue" "()F"+ 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 ('Class "java.lang.Float") where+ instance Reflect Float where reflect x = new [JFloat x] type instance Interp Text = 'Class "java.lang.String" - instance Reify Text ('Class "java.lang.String") where+ instance Reify Text where reify jobj = do sz <- getStringLength jobj cs <- getStringChars jobj@@ -480,46 +665,49 @@ releaseStringChars jobj cs return txt - instance Reflect Text ('Class "java.lang.String") where+ 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+#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) type instance Interp (IOVector Int32) = 'Array ('Prim "int") - instance Reify (IOVector Int32) ('Array ('Prim "int")) where+ instance Reify (IOVector Int32) where reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements) - instance Reflect (IOVector Int32) ('Array ('Prim "int")) where+ instance Reflect (IOVector Int32) where reflect = reflectMVector (newIntArray) (setIntArrayRegion) type instance Interp (Vector Int32) = 'Array ('Prim "int") - instance Reify (Vector Int32) ('Array ('Prim "int")) where+ instance Reify (Vector Int32) where reify = Vector.freeze <=< reify - instance Reflect (Vector Int32) ('Array ('Prim "int")) where+ instance Reflect (Vector Int32) where reflect = reflect <=< Vector.thaw #endif - type instance Interp [a] = 'Array (Interp (Uncurry a))+ type instance Interp [a] = 'Array (Interp a) - instance Reify a ty => Reify [a] ('Array ty) where+ instance Reify a => Reify [a] where reify jobj = do n <- getArrayLength jobj forM [0..n-1] $ \i -> do- x <- getObjectArrayElement jobj i- reify x+ jx <- getObjectArrayElement jobj i+ x <- reify jx+ deleteLocalRef jx+ return x - instance Reflect a ty => Reflect [a] ('Array ty) where+ instance Reflect a => Reflect [a] where reflect xs = do let n = fromIntegral (length xs)- array <- findClass (referenceTypeName (sing :: Sing ty))- >>= newObjectArray n- forM_ (zip [0..n-1] xs) $ \(i, x) ->- setObjectArrayElement array i =<< reflect x- return (unsafeCast array)+ 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/Language/Java/TH.hs
@@ -1,46 +0,0 @@--- | Optional code macros for convenience.--{-# LANGUAGE TemplateHaskell #-}--module Language.Java.TH (makeConversions) where--import Control.Distributed.Closure.TH (withStatic)-import qualified Language.Haskell.TH as TH-import Language.Java---- | Define instances of the three conversion classes, 'Coercible', 'Reify' and--- 'Reflect' for the given datatype. Example usage:------ @--- import qualified Language.Java.TH as Java------ newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane"))--- Java.makeConversions ''JOptionPane--- @------ This is equivalent to:------ @--- newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane"))--- instance Coercible JOptionPane ('Class "javax.swing.JOptionPane")--- instance Reify JOptionPane ('Class "javax.swing.JOptionPane")--- instance Reflect JOptionPane ('Class "javax.swing.JOptionPane")--- @-makeConversions :: TH.Name -> TH.Q [TH.Dec]-makeConversions x = do- info <- TH.reify x- let ty_x = return (TH.ConT x)- ty_cls = case info of- TH.TyConI (TH.DataD [] _ _ _ [cstr] _) -> case cstr of- TH.NormalC _ [(_, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty- TH.RecC _ [(_, _, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty- _ -> notsupported- _ -> notsupported- withStatic [d|- instance Coercible $ty_x $ty_cls- instance Reify $ty_x $ty_cls- instance Reflect $ty_x $ty_cls- |]- where- notsupported = fail- "makeConversions failed. Only newtype wrappers of (J ty) are supported."
tests/Language/JavaSpec.hs view
@@ -2,12 +2,15 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} module Language.JavaSpec where import Data.Int import qualified Data.Text as Text import Data.Text (Text)+import Foreign.JNI (getArrayLength) import Language.Java import Test.Hspec @@ -16,42 +19,72 @@ describe "callStatic" $ do it "can call double-returning static functions" $ do jstr <- reflect ("1.2345" :: Text)- callStatic (sing :: Sing "java.lang.Double") "parseDouble" [coerce jstr]+ callStatic "java.lang.Double" "parseDouble" [coerce jstr] `shouldReturn` (1.2345 :: Double) it "can call int-returning static functions" $ do jstr <- reflect ("12345" :: Text)- callStatic (sing :: Sing "java.lang.Integer") "parseInt" [coerce jstr]+ callStatic "java.lang.Integer" "parseInt" [coerce jstr] `shouldReturn` (12345 :: Int32) it "can call String-returning static functions" $ do jstr <- callStatic- (sing :: Sing "java.lang.Integer")+ "java.lang.Integer" "toString" [coerce (12345 :: Int32)] reify jstr `shouldReturn` ("12345" :: Text) + it "can get static fields" $ do+ getStaticField "java.lang.Math" "PI"+ `shouldReturn` (pi :: Double)++ it "can get enum values" $ do+ monday :: J ('Class "java.time.DayOfWeek") <-+ getStaticField "java.time.DayOfWeek" "MONDAY"+ 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 (sing :: Sing "java.lang.Short") "parseShort" [coerce maxshort]+ callStatic "java.lang.Short" "parseShort" [coerce maxshort] `shouldReturn` (maxBound :: Int16)- callStatic (sing :: Sing "java.lang.Short") "parseShort" [coerce minshort]+ callStatic "java.lang.Short" "parseShort" [coerce 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 (sing :: Sing "java.lang.Integer") "parseInt" [coerce maxint]+ callStatic "java.lang.Integer" "parseInt" [coerce maxint] `shouldReturn` (maxBound :: Int32)- callStatic (sing :: Sing "java.lang.Integer") "parseInt" [coerce minint]+ callStatic "java.lang.Integer" "parseInt" [coerce 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 (sing :: Sing "java.lang.Long") "parseLong" [coerce maxlong]+ callStatic "java.lang.Long" "parseLong" [coerce maxlong] `shouldReturn` (maxBound :: Int64)- callStatic (sing :: Sing "java.lang.Long") "parseLong" [coerce minlong]+ callStatic "java.lang.Long" "parseLong" [coerce minlong] `shouldReturn` (minBound :: Int64)++ describe "newArray" $ do+ it "Supports object arrays" $ do+ jxs <- newArray 10+ getArrayLength (jxs :: J ('Array ('Class "java.lang.Object")))+ `shouldReturn` 10++ it "supports generics" $ do+ jxs <- newArray 10+ getArrayLength (jxs ::+ J ('Array ('Class "java.util.List" <> '[ 'Class "java.lang.Long"]))+ )+ `shouldReturn` 10++ describe "reify" $ do+ -- 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"))+ reify (unsafeCast j) `shouldReturn` (fromIntegral i :: Int64)