packages feed

jni 0.6.1 → 0.8.0

raw patch · 24 files changed

Files

+ cpphs-cpp view
@@ -0,0 +1,4 @@+#!/bin/sh+# Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/17185+cpphs --cpp $@+exit $?
jni.cabal view
@@ -1,5 +1,5 @@ name:                jni-version:             0.6.1+version:             0.8.0 synopsis:            Complete JNI raw bindings. description:         Please see README.md. homepage:            https://github.com/tweag/inline-java/tree/master/jni#readme@@ -11,43 +11,81 @@ category:            FFI, JVM, Java build-type:          Simple cabal-version:       >=1.10-extra-source-files:  README.md+extra-source-files:  README.md cpphs-cpp  source-repository head   type: git   location: https://github.com/tweag/inline-java   subdir: jni +flag linear-types+  description: Build the linear types interface.+  default: False+ library-  hs-source-dirs: src-  if impl(ghc < 8.2.1)-    c-sources: src/Foreign/JNI.c+  hs-source-dirs: src/common   cc-options: -std=c11-  -- XXX pgmP directive should be redundant. But necessary to workaround-  -- https://github.com/haskell/cabal/issues/4278.-  -- Needed for Foreign.JNI.-  ghc-options: -pgmPcpphs -optP--cpp+  if os(darwin)+    -- XXX pgmP directive should be redundant. But necessary to workaround+    -- https://github.com/haskell/cabal/issues/4278.+    -- Needed for Foreign.JNI.+    -- XXX we use an auxiliary script here that passes --cpp to cpphs.+    -- Otherwise we hit https://gitlab.haskell.org/ghc/ghc/-/issues/17185+    ghc-options: -pgmP./cpphs-cpp   extra-libraries: jvm   exposed-modules:     Foreign.JNI     Foreign.JNI.Types     Foreign.JNI.String     Foreign.JNI.Internal+    Foreign.JNI.Internal.BackgroundWorker+    Foreign.JNI.Internal.RWLock+    Foreign.JNI.Unsafe+    Foreign.JNI.Unsafe.Internal+    Foreign.JNI.Unsafe.Internal.Introspection   other-modules:     Foreign.JNI.NativeMethod   build-depends:-    base >=4.7 && <5,+    async >=2.2.2,+    base >=4.14 && <5,     bytestring >=0.10,     choice >=0.2.0,     containers >=0.5,     constraints >=0.8,     deepseq >=1.4.2,-    singletons >=2.0-  if impl(ghc < 8.2.1)+    inline-c >=0.6,+    stm >= 2.3,+    text >= 1.2.3+  if flag(linear-types)+    hs-source-dirs: src/linear-types     build-depends:-      inline-c >=0.5.6.1 && <0.6+      linear-base ==0.1.0.0+    exposed-modules:+      Data.Singletons+      Foreign.JNI.Safe+      Foreign.JNI.Types.Safe   else     build-depends:-      inline-c >=0.6+      singletons >=2.6   build-tools: cpphs   default-language: Haskell2010++test-suite spec+  type:+    exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Main.hs+  other-modules:+    Foreign.JNISpec+    Spec+  build-depends:+    base,+    hspec,+    jni+  if !flag(linear-types)+    build-depends:+      singletons+  default-language: Haskell2010+  extra-libraries: pthread+  ghc-options: -threaded+  cpp-options: -DHSPEC_DISCOVER=hspec-discover
− src/Foreign/JNI.c 
− src/Foreign/JNI.hs 
@@ -1,985 +0,0 @@--- | Low-level bindings to the Java Native Interface (JNI).------ Read the--- <https://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/jniTOC.html JNI spec>--- for authoritative documentation as to what each of the functions in--- this module does. The names of the bindings in this module were chosen to--- match the names of the functions in the JNI spec.------ All bindings in this module access the JNI via a thread-local variable of--- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the--- JVM, it is attached implicitly upon the first call to one of these bindings--- in the current thread.------ The 'String' type in this module is the type of JNI strings. See--- "Foreign.JNI.String".--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- XXX This file uses cpphs for preprocessing instead of the system's native--- CPP, because the OS X has subtly different whitespace behaviour in the--- presence of concatenation.--module Foreign.JNI-  ( -- * JNI functions-    -- ** VM management-    withJVM-  , newJVM-  , destroyJVM-    -- ** Class loading-  , defineClass-  , JNINativeMethod(..)-  , registerNatives-    -- ** String wrappers-  , ReferenceTypeName-  , MethodSignature-  , Signature-    -- ** Exceptions-  , JVMException(..)-  , throw-  , throwNew-    -- ** Query functions-  , findClass-  , getFieldID-  , getStaticFieldID-  , getMethodID-  , getStaticMethodID-  , getObjectClass-    -- ** Reference manipulation-  , newGlobalRef-  , deleteGlobalRef-  , newGlobalRefNonFinalized-  , deleteGlobalRefNonFinalized-  , newLocalRef-  , deleteLocalRef-  , pushLocalFrame-  , popLocalFrame-    -- ** Field accessor functions-    -- *** Get fields-  , getObjectField-  , getBooleanField-  , getIntField-  , getLongField-  , getCharField-  , getShortField-  , getByteField-  , getDoubleField-  , getFloatField-    -- *** Get static fields-  , getStaticObjectField-  , getStaticBooleanField-  , getStaticIntField-  , getStaticLongField-  , getStaticCharField-  , getStaticShortField-  , getStaticByteField-  , getStaticDoubleField-  , getStaticFloatField-    -- *** Set fields-  , setObjectField-  , setBooleanField-  , setIntField-  , setLongField-  , setCharField-  , setShortField-  , setByteField-  , setDoubleField-  , setFloatField-    -- *** Set static fields-  , setStaticObjectField-  , setStaticBooleanField-  , setStaticIntField-  , setStaticLongField-  , setStaticCharField-  , setStaticShortField-  , setStaticByteField-  , setStaticDoubleField-  , setStaticFloatField-    -- ** Method invocation-  , callObjectMethod-  , callBooleanMethod-  , callIntMethod-  , callLongMethod-  , callCharMethod-  , callShortMethod-  , callByteMethod-  , callDoubleMethod-  , callFloatMethod-  , callVoidMethod-  , callStaticObjectMethod-  , callStaticVoidMethod-  , callStaticBooleanMethod-  , callStaticIntMethod-  , callStaticLongMethod-  , callStaticCharMethod-  , callStaticShortMethod-  , callStaticByteMethod-  , callStaticDoubleMethod-  , callStaticFloatMethod-    -- ** Object construction-  , newObject-  , newString-  , newObjectArray-  , newBooleanArray-  , newByteArray-  , newCharArray-  , newShortArray-  , newIntArray-  , newLongArray-  , newFloatArray-  , newDoubleArray-    -- ** Array manipulation-  , getArrayLength-  , getStringLength-  , ArrayCopyFailed(..)-  , NullPointerException(..)-  , getBooleanArrayElements-  , getByteArrayElements-  , getCharArrayElements-  , getShortArrayElements-  , getIntArrayElements-  , getLongArrayElements-  , getFloatArrayElements-  , getDoubleArrayElements-  , getStringChars-  , setBooleanArrayRegion-  , setByteArrayRegion-  , setCharArrayRegion-  , setShortArrayRegion-  , setIntArrayRegion-  , setLongArrayRegion-  , setFloatArrayRegion-  , setDoubleArrayRegion-  , releaseBooleanArrayElements-  , releaseByteArrayElements-  , releaseCharArrayElements-  , releaseShortArrayElements-  , releaseIntArrayElements-  , releaseLongArrayElements-  , releaseFloatArrayElements-  , releaseDoubleArrayElements-  , releaseStringChars-  , getObjectArrayElement-  , setObjectArrayElement-    -- * Thread management-  , attachCurrentThreadAsDaemon-  , detachCurrentThread-  , runInAttachedThread-  ) where--import Control.Concurrent (isCurrentThreadBound, rtsSupportsBoundThreads)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)-import Control.Exception (Exception, bracket, bracket_, catch, finally, throwIO)-import Control.Monad (join, unless, void, when)-import Data.Choice-import Data.Coerce-import Data.Int-import Data.IORef (IORef, newIORef, atomicModifyIORef)-import Data.Word-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Monoid ((<>))-import Data.Typeable (Typeable)-import Foreign.C (CChar)-import Foreign.ForeignPtr-  ( finalizeForeignPtr-  , newForeignPtr_-  , withForeignPtr-  )-import Foreign.JNI.Internal-import Foreign.JNI.NativeMethod-import Foreign.JNI.Types-import qualified Foreign.JNI.String as JNI-import Foreign.Marshal.Alloc (alloca)-import Foreign.Marshal.Array-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Storable (peek)-import GHC.ForeignPtr (newConcForeignPtr)-import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc)-import qualified Language.C.Inline as C-import qualified Language.C.Inline.Unsafe as CU-import System.IO (fixIO)-import System.IO.Unsafe (unsafePerformIO)-import Prelude hiding (String)-import qualified Prelude--C.context (C.baseCtx <> C.bsCtx <> jniCtx)--C.include "<jni.h>"-C.include "<stdio.h>"-C.include "<errno.h>"-C.include "<stdlib.h>"---- A thread-local variable to cache the JNI environment. Accessing this variable--- is faster than calling @jvm->GetEnv()@.-$(C.verbatim "static __thread JNIEnv* jniEnv; ")---- | A JNI call may cause a (Java) exception to be raised. This module raises it--- as a Haskell exception wrapping the Java exception.-newtype JVMException = JVMException JThrowable-  deriving (Show, Typeable)--instance Exception JVMException---- | Thrown when @Get<PrimitiveType>ArrayElements@ returns a null pointer,--- because it wanted to copy the array contents but couldn't. In this case the--- JVM doesn't throw OutOfMemory according to the JNI spec.-data ArrayCopyFailed = ArrayCopyFailed-  deriving (Exception, Show, Typeable)---- | A null reference is found where a non-null reference was expected.-data NullPointerException = NullPointerException-  deriving (Exception, Show, Typeable)---- | A JNI call is made from a thread not attached to the JVM.-data ThreadNotAttached = ThreadNotAttached-  deriving (Exception, Show, Typeable)---- | A JNI call is made from an unbound thread.-data ThreadNotBound = ThreadNotBound-  deriving (Exception, Show, Typeable)---- | Thrown when an JNI call is made from an unbound thread.-data JNIError = JNIError Prelude.String Int32-  deriving (Show, Typeable)--instance Exception JNIError---- | Map Java exceptions to Haskell exceptions.-throwIfException :: Ptr JNIEnv -> IO a -> IO a-throwIfException env m = m `finally` do-    excptr <- [CU.exp| jthrowable { (*$(JNIEnv *env))->ExceptionOccurred($(JNIEnv *env)) } |]-    unless (excptr == nullPtr) $ do-      [CU.exp| void { (*$(JNIEnv *env))->ExceptionDescribe($(JNIEnv *env)) } |]-      [CU.exp| void { (*$(JNIEnv *env))->ExceptionClear($(JNIEnv *env)) } |]-      throwIO . JVMException =<< newGlobalRef =<< objectFromPtr excptr---- | Check whether a pointer is null.-throwIfNull :: IO (Ptr a) -> IO (Ptr a)-throwIfNull m = do-    ptr <- m-    if ptr == nullPtr-    then throwIO ArrayCopyFailed-    else return ptr---- | Throws an error if the given reference is null, otherwise performs--- the given io action.-throwIfJNull :: J ty -> IO a -> IO a-throwIfJNull j io =-    if j == jnull-    then throwIO NullPointerException-    else io---- | A read-write lock------ Concurrent readers are allowed, but only one writer is supported.-newtype RWLock =-    RWLock (IORef (Int, RWWantedState))-    -- ^ A count of the held read locks and the wanted state---- | The wanted state of the RW-data RWWantedState-    = Reading            -- ^ There are no writers-    | Writing (MVar ())-       -- ^ A writer wants to write, grant no more read locks. The MVar is used-       -- to notify the writer when the currently held read locks are released.---- | Creates a new read-write lock.-newRWLock :: IO RWLock-newRWLock = RWLock <$> newIORef (0, Reading)---- | Tries to acquire a read lock. If this call returns `Do #read`, no writer--- will be granted a lock before the read lock is released.-tryAcquireReadLock :: RWLock -> IO (Choice "read")-tryAcquireReadLock (RWLock ref) = do-    atomicModifyIORef ref $ \case-      (!readers,  Reading) -> ((readers + 1, Reading),    Do #read)-      st                   -> (                       st, Don't #read)---- | Releases a read lock.-releaseReadLock :: RWLock -> IO ()-releaseReadLock (RWLock ref) = do-    st <- atomicModifyIORef ref $-            \st@(readers, aim) -> ((readers - 1, aim), st)-    case st of-      -- Notify the writer if I'm the last reader.-      (1, Writing mv) -> putMVar mv ()-      _               -> return ()---- | Waits until the current read locks are released and grants a write lock.-acquireWriteLock :: RWLock -> IO ()-acquireWriteLock (RWLock ref) = do-    mv <- newEmptyMVar-    join $ atomicModifyIORef ref $ \(readers, _) ->-      ((readers, Writing mv), when (readers > 0) (takeMVar mv))---- | This lock is used to avoid the JVM from dying before any finalizers--- deleting global references are finished.------ Finalizers try to acquire read locks.------ The JVM acquires a write lock before shutdown. Thence, finalizers fail to--- acquire read locks and behave as noops.-globalJVMLock :: RWLock-globalJVMLock = unsafePerformIO newRWLock-{-# NOINLINE globalJVMLock #-}--throwIfNotOK_ :: HasCallStack => IO Int32 -> IO ()-throwIfNotOK_ m = m >>= \case-  rc-    | rc == [CU.pure| jint { JNI_OK } |] -> return ()-    | rc == [CU.pure| jint { JNI_EDETACHED } |] -> throwIO ThreadNotAttached-    | otherwise -> throwIO $ JNIError (prettySrcLoc loc) rc-  where-    (_, loc):_ = getCallStack callStack--attachCurrentThreadAsDaemon :: IO ()-attachCurrentThreadAsDaemon = do-    throwIfNotOK_-      [CU.exp| jint {-        (*$(JavaVM* jvm))->AttachCurrentThreadAsDaemon($(JavaVM* jvm), (void**)&jniEnv, NULL)-      } |]--detachCurrentThread :: IO ()-detachCurrentThread =-    throwIfNotOK_-    [CU.block| jint {-      int rc = (*$(JavaVM* jvm))->DetachCurrentThread($(JavaVM* jvm));-      if (rc == JNI_OK)-        jniEnv = NULL;-      return rc;-    } |]---- | Attaches the calling thread to the JVM, runs the given IO action and--- then detaches the thread.------ If the thread is already attached no attaching and detaching is performed.-runInAttachedThread :: IO a -> IO a-runInAttachedThread io = do-    attached <--      catch (getJNIEnv >> return True) (\ThreadNotBound -> return False)-    if attached-    then io-    else bracket_-          attachCurrentThreadAsDaemon-          detachCurrentThread-          io---- | The current JVM------ Assumes there's at most one JVM. The current JNI spec (2016) says only--- one JVM per process is supported anyways.-{-# NOINLINE jvm #-}-jvm :: Ptr JVM-jvm = unsafePerformIO $ alloca $ \pjvm -> alloca $ \pnum_jvms -> do-    throwIfNotOK_-      [CU.exp| jint {-        JNI_GetCreatedJavaVMs($(JavaVM** pjvm), 1, $(jsize* pnum_jvms))-      }|]-    num_jvms <- peek pnum_jvms-    when (num_jvms == 0) $-      fail "JNI_GetCreatedJavaVMs: No JVM has been initialized yet."-    when (num_jvms > 1) $-      fail "JNI_GetCreatedJavaVMs: There are multiple JVMs but only one is supported."-    peek pjvm---- | Yields the JNIEnv of the calling thread.------ Yields @Nothing@ if the calling thread is not attached to the JVM.-getJNIEnv :: IO (Ptr JNIEnv)-getJNIEnv = [CU.exp| JNIEnv* { jniEnv } |] >>= \case-    env | env == nullPtr -> do-      throwIfNotOK_-        [CU.exp| jint {-          (*$(JavaVM* jvm))->GetEnv($(JavaVM* jvm), (void**)&jniEnv, JNI_VERSION_1_6)-        }|]-      [CU.exp| JNIEnv* { jniEnv } |]-    env -> return env---- | Run an action against the appropriate 'JNIEnv'.------ Each OS thread has its own 'JNIEnv', which this function gives access to.-withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a-withJNIEnv f = getJNIEnv >>= f--useAsCStrings :: [ByteString] -> ([Ptr CChar] -> IO a) -> IO a-useAsCStrings strs m =-  foldr (\str k cstrs -> BS.useAsCString str $ \cstr -> k (cstr:cstrs)) m strs []---- | Create a new JVM, with the given arguments. /Can only be called once/. Best--- practice: use 'withJVM' instead. Only useful for GHCi.-newJVM :: [ByteString] -> IO JVM-newJVM options = JVM_ <$> do-    useAsCStrings options $ \cstrs -> do-      withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do-        let n = fromIntegral (length cstrs) :: C.CInt-        checkBoundness-        [C.block| JavaVM * {-          JavaVM *jvm;-          JavaVMInitArgs vm_args;-          JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n));-          for(int i = 0; i < $(int n); i++)-                  options[i].optionString = $(char **coptions)[i];-          vm_args.version = JNI_VERSION_1_6;-          vm_args.nOptions = $(int n);-          vm_args.options = options;-          vm_args.ignoreUnrecognized = 0;-          JNI_CreateJavaVM(&jvm, (void**)&jniEnv, &vm_args);-          free(options);-          return jvm; } |]--  where-    checkBoundness :: IO ()-    checkBoundness = when rtsSupportsBoundThreads $ do-      bound <- isCurrentThreadBound-      unless bound (throwIO ThreadNotBound)---- | Deallocate a 'JVM' created using 'newJVM'.-destroyJVM :: JVM -> IO ()-destroyJVM (JVM_ jvm) = do-    acquireWriteLock globalJVMLock-    [C.block| void {-        (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm));-        jniEnv = NULL;-    } |]---- | Create a new JVM, with the given arguments. Destroy it once the given--- action completes. /Can only be called once/. Best practice: use it to wrap--- your @main@ function.-withJVM :: [ByteString] -> IO a -> IO a-withJVM options action = bracket (newJVM options) destroyJVM (const action)--defineClass-  :: Coercible o (J ('Class "java.lang.ClassLoader"))-  => ReferenceTypeName -- ^ Class name-  -> o -- ^ Loader-  -> ByteString -- ^ Bytecode buffer-  -> IO JClass-defineClass (coerce -> name) (coerce -> upcast -> loader) buf = withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString name $ \namep ->-    objectFromPtr =<<-    [CU.exp| jclass {-      (*$(JNIEnv *env))->DefineClass($(JNIEnv *env),-                                     $(char *namep),-                                     $fptr-ptr:(jobject loader),-                                     $bs-ptr:buf,-                                     $bs-len:buf) } |]-registerNatives-  :: JClass-  -> [JNINativeMethod]-  -> IO ()-registerNatives cls methods = withJNIEnv $ \env ->-    throwIfException env $-    withArray methods $ \cmethods -> do-      let numMethods = fromIntegral $ length methods-      _ <- [CU.exp| jint {-             (*$(JNIEnv *env))->RegisterNatives($(JNIEnv *env),-                                                $fptr-ptr:(jclass cls),-                                                $(JNINativeMethod *cmethods),-                                                $(int numMethods)) } |]-      return ()--throw :: Coercible o (J a) => o -> IO ()-throw (coerce -> upcast -> obj) = withJNIEnv $ \env -> void $ do-    [CU.exp| jint {-       (*$(JNIEnv *env))->Throw($(JNIEnv *env),-                                $fptr-ptr:(jobject obj)) } |]--throwNew :: JClass -> JNI.String -> IO ()-throwNew cls msg = throwIfJNull cls $ withJNIEnv $ \env ->-    JNI.withString msg $ \msgp -> void $ do-    [CU.exp| jint {-       (*$(JNIEnv *env))->ThrowNew($(JNIEnv *env),-                                   $fptr-ptr:(jclass cls),-                                   $(char *msgp)) } |]--findClass-  :: ReferenceTypeName -- ^ Class name-  -> IO JClass-findClass (coerce -> name) = withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString name $ \namep ->-    objectFromPtr =<<-    [CU.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $(char *namep)) } |]--newObject :: JClass -> MethodSignature -> [JValue] -> IO JObject-newObject cls (coerce -> sig) args = throwIfJNull cls $ withJNIEnv $ \env ->-    throwIfException env $-    withJValues args $ \cargs -> do-      constr <- getMethodID cls "<init>" sig-      objectFromPtr =<< [CU.exp| jobject {-        (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env),-                                      $fptr-ptr:(jclass cls),-                                      $(jmethodID constr),-                                      $(jvalue *cargs)) } |]--getFieldID-  :: JClass -- ^ A class object as returned by 'findClass'-  -> JNI.String -- ^ Field name-  -> Signature -- ^ JNI signature-  -> IO JFieldID-getFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $-    withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString fieldname $ \fieldnamep ->-    JNI.withString sig $ \sigp ->-    [CU.exp| jfieldID {-      (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env),-                                    $fptr-ptr:(jclass cls),-                                    $(char *fieldnamep),-                                    $(char *sigp)) } |]--getStaticFieldID-  :: JClass -- ^ A class object as returned by 'findClass'-  -> JNI.String -- ^ Field name-  -> Signature -- ^ JNI signature-  -> IO JFieldID-getStaticFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $-    withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString fieldname $ \fieldnamep ->-    JNI.withString sig $ \sigp ->-    [CU.exp| jfieldID {-      (*$(JNIEnv *env))->GetStaticFieldID($(JNIEnv *env),-                                          $fptr-ptr:(jclass cls),-                                          $(char *fieldnamep),-                                          $(char *sigp)) } |]--#define GET_FIELD(name, hs_rettype, c_rettype) \-get/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> IO hs_rettype; \-get/**/name/**/Field (coerce -> upcast -> obj) field = withJNIEnv $ \env -> \-    throwIfException env $ \-    [CU.exp| c_rettype { \-      (*$(JNIEnv *env))->Get/**/name/**/Field($(JNIEnv *env), \-                                              $fptr-ptr:(jobject obj), \-                                              $(jfieldID field)) } |]--getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject-getObjectField x y =-    let GET_FIELD(Object, (Ptr JObject), jobject)-    in objectFromPtr =<< getObjectField x y-GET_FIELD(Boolean, Word8, jboolean)-GET_FIELD(Byte, CChar, jbyte)-GET_FIELD(Char, Word16, jchar)-GET_FIELD(Short, Int16, jshort)-GET_FIELD(Int, Int32, jint)-GET_FIELD(Long, Int64, jlong)-GET_FIELD(Float, Float, jfloat)-GET_FIELD(Double, Double, jdouble)--#define GET_STATIC_FIELD(name, hs_rettype, c_rettype) \-getStatic/**/name/**/Field :: JClass -> JFieldID -> IO hs_rettype; \-getStatic/**/name/**/Field klass field = throwIfJNull klass $ \-    withJNIEnv $ \env -> \-    throwIfException env $ \-    [CU.exp| c_rettype { \-      (*$(JNIEnv *env))->GetStatic/**/name/**/Field($(JNIEnv *env), \-                                                    $fptr-ptr:(jclass klass), \-                                                    $(jfieldID field)) } |]--getStaticObjectField :: JClass -> JFieldID -> IO JObject-getStaticObjectField x y =-    let GET_STATIC_FIELD(Object, (Ptr JObject), jobject)-    in objectFromPtr =<< getStaticObjectField x y-GET_STATIC_FIELD(Boolean, Word8, jboolean)-GET_STATIC_FIELD(Byte, CChar, jbyte)-GET_STATIC_FIELD(Char, Word16, jchar)-GET_STATIC_FIELD(Short, Int16, jshort)-GET_STATIC_FIELD(Int, Int32, jint)-GET_STATIC_FIELD(Long, Int64, jlong)-GET_STATIC_FIELD(Float, Float, jfloat)-GET_STATIC_FIELD(Double, Double, jdouble)--#define SET_FIELD(name, hs_fieldtype, c_fieldtype) \-set/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> hs_fieldtype -> IO (); \-set/**/name/**/Field (coerce -> upcast -> obj) field x = \-    withJNIEnv $ \env -> \-    throwIfException env $ \-    [CU.block| void { \-      (*$(JNIEnv *env))->Set/**/name/**/Field($(JNIEnv *env), \-                                              $fptr-ptr:(jobject obj), \-                                              $(jfieldID field), \-                                              $(c_fieldtype x)); } |]--setObjectField :: Coercible o (J a) => o -> JFieldID -> JObject -> IO ()-setObjectField x y z =-    let SET_FIELD(Object, (Ptr JObject), jobject)-    in withForeignPtr (coerce z) (setObjectField x y)-SET_FIELD(Boolean, Word8, jboolean)-SET_FIELD(Byte, CChar, jbyte)-SET_FIELD(Char, Word16, jchar)-SET_FIELD(Short, Int16, jshort)-SET_FIELD(Int, Int32, jint)-SET_FIELD(Long, Int64, jlong)-SET_FIELD(Float, Float, jfloat)-SET_FIELD(Double, Double, jdouble)--#define SET_STATIC_FIELD(name, hs_fieldtype, c_fieldtype) \-setStatic/**/name/**/Field :: JClass -> JFieldID -> hs_fieldtype -> IO (); \-setStatic/**/name/**/Field klass field x = throwIfJNull klass $ \-    withJNIEnv $ \env -> \-    throwIfException env $ \-    [CU.block| void { \-      (*$(JNIEnv *env))->SetStatic/**/name/**/Field($(JNIEnv *env), \-                                                    $fptr-ptr:(jclass klass), \-                                                    $(jfieldID field), \-                                                    $(c_fieldtype x)); } |]--setStaticObjectField :: JClass -> JFieldID -> JObject -> IO ()-setStaticObjectField x y z =-    let SET_STATIC_FIELD(Object, (Ptr JObject), jobject)-    in withForeignPtr (coerce z) (setStaticObjectField x y)-SET_STATIC_FIELD(Boolean, Word8, jboolean)-SET_STATIC_FIELD(Byte, CChar, jbyte)-SET_STATIC_FIELD(Char, Word16, jchar)-SET_STATIC_FIELD(Short, Int16, jshort)-SET_STATIC_FIELD(Int, Int32, jint)-SET_STATIC_FIELD(Long, Int64, jlong)-SET_STATIC_FIELD(Float, Float, jfloat)-SET_STATIC_FIELD(Double, Double, jdouble)--getMethodID-  :: JClass -- ^ A class object as returned by 'findClass'-  -> JNI.String -- ^ Field name-  -> MethodSignature -- ^ JNI signature-  -> IO JMethodID-getMethodID cls methodname (coerce -> sig) = throwIfJNull cls $-    withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString methodname $ \methodnamep ->-    JNI.withString sig $ \sigp ->-    [CU.exp| jmethodID {-      (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env),-                                     $fptr-ptr:(jclass cls),-                                     $(char *methodnamep),-                                     $(char *sigp)) } |]--getStaticMethodID-  :: JClass -- ^ A class object as returned by 'findClass'-  -> JNI.String -- ^ Field name-  -> MethodSignature -- ^ JNI signature-  -> IO JMethodID-getStaticMethodID cls methodname (coerce -> sig) = throwIfJNull cls $-    withJNIEnv $ \env ->-    throwIfException env $-    JNI.withString methodname $ \methodnamep ->-    JNI.withString sig $ \sigp ->-    [CU.exp| jmethodID {-      (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env),-                                           $fptr-ptr:(jclass cls),-                                           $(char *methodnamep),-                                           $(char *sigp)) } |]--getObjectClass :: Coercible o (J ty) => o -> IO JClass-getObjectClass (coerce -> upcast -> obj) = throwIfJNull obj $-    withJNIEnv $ \env ->-    objectFromPtr =<<-    [CU.exp| jclass {-      (*$(JNIEnv *env))->GetObjectClass($(JNIEnv *env),-                                        $fptr-ptr:(jobject obj)) } |]---- | Creates a global reference to the object referred to by--- the given reference.------ Arranges for a finalizer to call 'deleteGlobalRef' when the--- global reference is no longer reachable on the Haskell side.-newGlobalRef :: Coercible o (J ty) => o -> IO o-newGlobalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> do-    gobj <--      [CU.exp| jobject {-        (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env),-                                        $fptr-ptr:(jobject obj)) } |]-    fixIO $ \j ->-      coerce <$> J <$> newConcForeignPtr gobj (deleteGlobalRefNonFinalized j)--deleteGlobalRef :: Coercible o (J ty) => o -> IO ()-deleteGlobalRef (coerce -> J p) = finalizeForeignPtr p---- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy--- the reference when it is not longer reachable. Use--- 'deleteGlobalRefNonFinalized' to destroy this reference.-newGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO o-newGlobalRefNonFinalized (coerce -> upcast -> obj) = withJNIEnv $ \env -> do-    gobj <--      [CU.exp| jobject {-        (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env),-                                        $fptr-ptr:(jobject obj)) } |]-    coerce <$> J <$> newForeignPtr_ gobj---- | Like 'deleteGlobalRef' but it can be used only on references created with--- 'newGlobalRefNonFinalized'.-deleteGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO ()-deleteGlobalRefNonFinalized (coerce -> upcast -> obj) = do-    bracket (tryAcquireReadLock globalJVMLock)-            (\doRead -> when (toBool doRead) $ releaseReadLock globalJVMLock)-            $ \doRead ->-      when (toBool doRead) $ withJNIEnv $ \env -> do-        [CU.block| void { (*$(JNIEnv *env))->DeleteGlobalRef($(JNIEnv *env)-                                                            ,$fptr-ptr:(jobject obj));-                        } |]---- NB: Cannot add a finalizer to local references because it may--- run in a thread where the reference is not valid.-newLocalRef :: Coercible o (J ty) => o -> IO o-newLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env ->-    coerce <$> (objectFromPtr =<<)-    [CU.exp| jobject {-      (*$(JNIEnv *env))->NewLocalRef($(JNIEnv *env),-                                     $fptr-ptr:(jobject obj)) } |]--deleteLocalRef :: Coercible o (J ty) => o -> IO ()-deleteLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env ->-    [CU.exp| void {-      (*$(JNIEnv *env))->DeleteLocalRef($(JNIEnv *env),-                                        $fptr-ptr:(jobject obj)) } |]--pushLocalFrame :: Int32 -> IO ()-pushLocalFrame (coerce -> capacity) = withJNIEnv $ \env ->-    -- We ignore the output as it is always 0 on success and throws an-    -- exception otherwise.-    throwIfException env $ void $-    [CU.block| jint {-      (*$(JNIEnv *env))->PushLocalFrame($(JNIEnv *env),-                                        $(jint capacity)); } |]--popLocalFrame :: Coercible o (J ty) => o -> IO o-popLocalFrame (coerce -> upcast -> obj) = withJNIEnv $ \env ->-    coerce <$> (objectFromPtr =<<)-    [CU.exp| jobject {-      (*$(JNIEnv *env))->PopLocalFrame($(JNIEnv *env),-                                       $fptr-ptr:(jobject obj)) } |]---- Modern CPP does have ## for concatenating strings, but we use the hacky /**/--- comment syntax for string concatenation. This is because GHC passes--- the -traditional flag to the preprocessor by default, which turns off several--- modern CPP features.--#define CALL_METHOD(name, hs_rettype, c_rettype) \-call/**/name/**/Method :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO hs_rettype; \-call/**/name/**/Method (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> \-    throwIfException env $ \-    withJValues args $ \cargs -> \-    [C.exp| c_rettype { \-      (*$(JNIEnv *env))->Call/**/name/**/MethodA($(JNIEnv *env), \-                                                 $fptr-ptr:(jobject obj), \-                                                 $(jmethodID method), \-                                                 $(jvalue *cargs)) } |]--CALL_METHOD(Void, (), void)-callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject-callObjectMethod x y z =-    let CALL_METHOD(Object, (Ptr JObject), jobject)-    in objectFromPtr =<< callObjectMethod x y z-callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool-callBooleanMethod x y z =-    let CALL_METHOD(Boolean, Word8, jboolean)-    in toEnum . fromIntegral <$> callBooleanMethod x y z-CALL_METHOD(Byte, CChar, jbyte)-CALL_METHOD(Char, Word16, jchar)-CALL_METHOD(Short, Int16, jshort)-CALL_METHOD(Int, Int32, jint)-CALL_METHOD(Long, Int64, jlong)-CALL_METHOD(Float, Float, jfloat)-CALL_METHOD(Double, Double, jdouble)--#define CALL_STATIC_METHOD(name, hs_rettype, c_rettype) \-callStatic/**/name/**/Method :: JClass -> JMethodID -> [JValue] -> IO hs_rettype; \-callStatic/**/name/**/Method cls method args = throwIfJNull cls $ \-    withJNIEnv $ \env -> \-    throwIfException env $ \-    withJValues args $ \cargs -> \-    [C.exp| c_rettype { \-      (*$(JNIEnv *env))->CallStatic/**/name/**/MethodA($(JNIEnv *env), \-                                                       $fptr-ptr:(jclass cls), \-                                                       $(jmethodID method), \-                                                       $(jvalue *cargs)) } |]--CALL_STATIC_METHOD(Void, (), void)-callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject-callStaticObjectMethod x y z =-    let CALL_STATIC_METHOD(Object, (Ptr JObject), jobject)-    in objectFromPtr =<< callStaticObjectMethod x y z-callStaticBooleanMethod :: JClass -> JMethodID -> [JValue] -> IO Bool-callStaticBooleanMethod x y z =-    let CALL_STATIC_METHOD(Boolean, Word8, jboolean)-    in toEnum . fromIntegral <$> callStaticBooleanMethod x y z-CALL_STATIC_METHOD(Byte, CChar, jbyte)-CALL_STATIC_METHOD(Char, Word16, jchar)-CALL_STATIC_METHOD(Short, Int16, jshort)-CALL_STATIC_METHOD(Int, Int32, jint)-CALL_STATIC_METHOD(Long, Int64, jlong)-CALL_STATIC_METHOD(Float, Float, jfloat)-CALL_STATIC_METHOD(Double, Double, jdouble)--newObjectArray :: Int32 -> JClass -> IO JObjectArray-newObjectArray sz cls = throwIfJNull cls $ withJNIEnv $ \env ->-    throwIfException env $-    objectFromPtr =<<-    [CU.exp| jobjectArray {-      (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env),-                                        $(jsize sz),-                                        $fptr-ptr:(jclass cls),-                                        NULL) } |]--#define NEW_ARRAY(name, c_rettype) \-new/**/name/**/Array :: Int32 -> IO J/**/name/**/Array; \-new/**/name/**/Array sz = withJNIEnv $ \env -> \-    throwIfException env $ \-    objectFromPtr =<< \-    [CU.exp| c_rettype/**/Array { \-      (*$(JNIEnv *env))->New/**/name/**/Array($(JNIEnv *env), \-                                              $(jsize sz)) } |]--NEW_ARRAY(Boolean, jboolean)-NEW_ARRAY(Byte, jbyte)-NEW_ARRAY(Char, jchar)-NEW_ARRAY(Short, jshort)-NEW_ARRAY(Int, jint)-NEW_ARRAY(Long, jlong)-NEW_ARRAY(Float, jfloat)-NEW_ARRAY(Double, jdouble)--newString :: Ptr Word16 -> Int32 -> IO JString-newString ptr len = withJNIEnv $ \env ->-    throwIfException env $-    objectFromPtr =<<-    [CU.exp| jstring {-      (*$(JNIEnv *env))->NewString($(JNIEnv *env),-                                   $(jchar *ptr),-                                   $(jsize len)) } |]--getArrayLength :: Coercible o (JArray a) => o -> IO Int32-getArrayLength (coerce -> upcast -> array) = throwIfJNull array $-    withJNIEnv $ \env ->-    [C.exp| jsize {-      (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env),-                                        $fptr-ptr:(jarray array)) } |]--getStringLength :: JString -> IO Int32-getStringLength jstr = throwIfJNull jstr $ withJNIEnv $ \env ->-    [CU.exp| jsize {-      (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env),-                                         $fptr-ptr:(jstring jstr)) } |]--#define GET_ARRAY_ELEMENTS(name, hs_rettype, c_rettype) \-get/**/name/**/ArrayElements :: J/**/name/**/Array -> IO (Ptr hs_rettype); \-get/**/name/**/ArrayElements (upcast -> array) = throwIfJNull array $ \-    withJNIEnv $ \env -> \-    throwIfNull $ \-    [CU.exp| c_rettype* { \-      (*$(JNIEnv *env))->Get/**/name/**/ArrayElements($(JNIEnv *env), \-                                                      $fptr-ptr:(jobject array), \-                                                      NULL) } |]--GET_ARRAY_ELEMENTS(Boolean, Word8, jboolean)-GET_ARRAY_ELEMENTS(Byte, CChar, jbyte)-GET_ARRAY_ELEMENTS(Char, Word16, jchar)-GET_ARRAY_ELEMENTS(Short, Int16, jshort)-GET_ARRAY_ELEMENTS(Int, Int32, jint)-GET_ARRAY_ELEMENTS(Long, Int64, jlong)-GET_ARRAY_ELEMENTS(Float, Float, jfloat)-GET_ARRAY_ELEMENTS(Double, Double, jdouble)--getStringChars :: JString -> IO (Ptr Word16)-getStringChars jstr = throwIfJNull jstr $ withJNIEnv $ \env ->-    throwIfNull $-    [CU.exp| const jchar* {-      (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env),-                                        $fptr-ptr:(jstring jstr),-                                        NULL) } |]--#define SET_ARRAY_REGION(name, hs_argtype, c_argtype) \-set/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \-set/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \-    withJNIEnv $ \env -> \-    throwIfException env $ \-    [CU.exp| void { \-      (*$(JNIEnv *env))->Set/**/name/**/ArrayRegion($(JNIEnv *env), \-                                                    $fptr-ptr:(c_argtype/**/Array array), \-                                                    $(jsize start), \-                                                    $(jsize len), \-                                                    $(c_argtype *buf)) } |]--SET_ARRAY_REGION(Boolean, Word8, jboolean)-SET_ARRAY_REGION(Byte, CChar, jbyte)-SET_ARRAY_REGION(Char, Word16, jchar)-SET_ARRAY_REGION(Short, Int16, jshort)-SET_ARRAY_REGION(Int, Int32, jint)-SET_ARRAY_REGION(Long, Int64, jlong)-SET_ARRAY_REGION(Float, Float, jfloat)-SET_ARRAY_REGION(Double, Double, jdouble)--#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype, c_argtype) \-release/**/name/**/ArrayElements :: J/**/name/**/Array -> Ptr hs_argtype -> IO (); \-release/**/name/**/ArrayElements (upcast -> array) xs = throwIfJNull array $ \-    withJNIEnv $ \env -> \-    [CU.exp| void { \-      (*$(JNIEnv *env))->Release/**/name/**/ArrayElements($(JNIEnv *env), \-                                                          $fptr-ptr:(jobject array), \-                                                          $(c_argtype *xs), \-                                                          JNI_ABORT) } |]--RELEASE_ARRAY_ELEMENTS(Boolean, Word8, jboolean)-RELEASE_ARRAY_ELEMENTS(Byte, CChar, jbyte)-RELEASE_ARRAY_ELEMENTS(Char, Word16, jchar)-RELEASE_ARRAY_ELEMENTS(Short, Int16, jshort)-RELEASE_ARRAY_ELEMENTS(Int, Int32, jint)-RELEASE_ARRAY_ELEMENTS(Long, Int64, jlong)-RELEASE_ARRAY_ELEMENTS(Float, Float, jfloat)-RELEASE_ARRAY_ELEMENTS(Double, Double, jdouble)--releaseStringChars :: JString -> Ptr Word16 -> IO ()-releaseStringChars jstr chars = throwIfJNull jstr $ withJNIEnv $ \env ->-    [CU.exp| void {-      (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env),-                                            $fptr-ptr:(jstring jstr),-                                            $(jchar *chars)) } |]--getObjectArrayElement-  :: forall a o.-     (IsReferenceType a, Coercible o (J a))-  => JArray a-  -> Int32-  -> IO o-getObjectArrayElement (arrayUpcast -> array) i = throwIfJNull array $-    withJNIEnv $ \env ->-    ( (coerce :: J a -> o)-    . (unsafeCast :: JObject -> J a)-    ) <$> (objectFromPtr =<<)-    [C.exp| jobject {-      (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env),-                                               $fptr-ptr:(jarray array),-                                               $(jsize i)) } |]--setObjectArrayElement-  :: forall a o.-     (IsReferenceType a, Coercible o (J a))-  => JArray a-  -> Int32-  -> o-  -> IO ()-setObjectArrayElement (arrayUpcast -> array)-                      i-                      ((coerce :: o -> J a) -> upcast -> x) =-    throwIfJNull array $-    withJNIEnv $ \env ->-    [C.exp| void {-      (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env),-                                               $fptr-ptr:(jobjectArray array),-                                               $(jsize i),-                                               $fptr-ptr:(jobject x)); } |]
− src/Foreign/JNI/Internal.hs 
@@ -1,25 +0,0 @@-module Foreign.JNI.Internal where--import qualified Foreign.JNI.String as JNI---- | A reference type name is not just any 'JNI.String', but a fully qualified--- identifier well-formed by construction.-newtype ReferenceTypeName = ReferenceTypeName JNI.String-  deriving (Eq, Ord)--instance Show ReferenceTypeName where-  show (ReferenceTypeName str) = show str---- | A string representing a signature, well-formed by construction.-newtype Signature = Signature JNI.String-  deriving (Eq, Ord)--instance Show Signature where-  show (Signature str) = show str---- | A string representing a method signature, well-formed by construction.-newtype MethodSignature = MethodSignature JNI.String-  deriving (Eq, Ord)--instance Show MethodSignature where-  show (MethodSignature str) = show str
− src/Foreign/JNI/NativeMethod.hsc 
@@ -1,42 +0,0 @@--- | Bindings to the JNINativeMethod struct.--{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RecordWildCards #-}--module Foreign.JNI.NativeMethod where--import qualified Data.ByteString.Unsafe as BS-import Data.Coerce (coerce)-import Foreign.JNI.Internal-import qualified Foreign.JNI.String as JNI-import Foreign.Ptr (FunPtr)-import Foreign.Storable (Storable(..))--#include <jni.h>--#if __GLASGOW_HASKELL__ < 800-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)-#endif--data JNINativeMethod = forall a. JNINativeMethod-  { jniNativeMethodName :: JNI.String-  , jniNativeMethodSignature :: MethodSignature-  , jniNativeMethodFunPtr :: FunPtr a-  }--instance Storable JNINativeMethod where-  sizeOf _ = #{size JNINativeMethod}-  alignment _ = #{alignment JNINativeMethod}-  peek ptr = do-      name <- BS.unsafePackCString =<< #{peek JNINativeMethod, name} ptr-      sig <- BS.unsafePackCString =<< #{peek JNINativeMethod, signature} ptr-      fptr <- #{peek JNINativeMethod, fnPtr} ptr-      return $-        JNINativeMethod-          (JNI.unsafeFromByteString name)-          (coerce (JNI.unsafeFromByteString sig))-          fptr-  poke ptr JNINativeMethod{..} = do-      JNI.withString jniNativeMethodName $ #{poke JNINativeMethod, name} ptr-      JNI.withString (coerce jniNativeMethodSignature) $ #{poke JNINativeMethod, signature} ptr-      #{poke JNINativeMethod, fnPtr} ptr jniNativeMethodFunPtr
− src/Foreign/JNI/String.hs 
@@ -1,75 +0,0 @@--- | JNI strings. Like C strings and unlike 'Data.ByteString.ByteString', these--- are null-terminated. Unlike C strings, each character is (multi-byte) encoded--- as UTF-8. Unlike UTF-8, embedded NULL characters are encoded as two bytes and--- the four-byte UTF-8 format for characters is not recognized. A custom--- encoding is used instead. See--- <http://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/types.html#modified_utf_8_strings>--- for more details.------ /NOTE:/ the current implementation does not support embedded NULL's and--- four-byte characters.--{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MagicHash #-}--module Foreign.JNI.String-  ( String-  , toChars-  , fromChars-  , fromByteString-  , unsafeFromByteString-  , toByteString-  , withString-  ) where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString.Unsafe as BS-import Data.ByteString (ByteString)-import Data.String (IsString(..))-import Foreign.C.String (CString)-import qualified GHC.Foreign as GHC-import qualified GHC.IO.Encoding as GHC-import System.IO.Unsafe (unsafeDupablePerformIO)-import qualified Prelude-import Prelude hiding (String)---- A JNI string is represented as a NUL terminated bytestring in UTF-8 encoding.-newtype String = String ByteString-  deriving (Eq, Ord)--instance Show String where-  show str = show (toChars str)--instance IsString String where-  fromString str = fromChars str--fromChars :: Prelude.String -> String-{-# INLINE [0] fromChars #-}-fromChars str = unsafeDupablePerformIO $-    GHC.withCString GHC.utf8 str $ \cstr -> do-      -- we need to copy the trailing NUL-      len <- BS.c_strlen cstr-      String <$> BS.packCStringLen (cstr, fromIntegral len + 1)--toChars :: String -> Prelude.String-toChars (String bs) = unsafeDupablePerformIO $ BS.unsafeUseAsCString bs $ GHC.peekCString GHC.utf8--withString :: String -> (CString -> IO a) -> IO a-withString (String bs) f = BS.unsafeUseAsCString bs f---- Discards the trailing NUL.-toByteString :: String -> ByteString-toByteString (String bs) = BS.init bs---- | O(1) if the input is null-terminated. Otherwise the input is copied into--- a null-terminated buffer first.-fromByteString :: ByteString -> String-fromByteString bs-  | BS.last bs == 0 = String bs-  | otherwise = String (bs `BS.snoc` 0)---- | Same as 'fromByteString', but doesn't check whether the input is--- null-terminated or not.-unsafeFromByteString :: ByteString -> String-unsafeFromByteString = String
− src/Foreign/JNI/Types.hs 
@@ -1,464 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif--module Foreign.JNI.Types-  ( JType(..)-  , IsPrimitiveType-  , IsReferenceType-  , Sing(..)-  , type (<>)-    -- * JNI types-  , J(..)-  , jnull-  , upcast-  , arrayUpcast-  , unsafeCast-  , generic-  , unsafeUngeneric-  , jtypeOf-  , ReferenceTypeName-  , singToIsReferenceType-  , referenceTypeName-  , Signature-  , signature-  , MethodSignature-  , methodSignature-  , JVM(..)-  , JNIEnv(..)-  , JMethodID(..)-  , JFieldID(..)-  , JValue(..)-  , withJValues-    -- * Conversions-  , objectFromPtr-  , unsafeObjectToPtr-    -- * JNI defined object types-  , JObject-  , JClass-  , JString-  , JArray-  , JObjectArray-  , JBooleanArray-  , JByteArray-  , JCharArray-  , JShortArray-  , JIntArray-  , JLongArray-  , JFloatArray-  , JDoubleArray-  , JThrowable-  -- * inline-c contexts-  , jniCtx-  ) where--import Control.DeepSeq (NFData)-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Builder as Builder-import qualified Data.ByteString.Builder.Prim as Prim-import Data.ByteString.Builder (Builder)-import Data.Char (chr, ord)-import Data.Constraint (Dict(..))-import Data.Int-import qualified Data.Map as Map-import Data.Monoid ((<>))-import Data.Singletons-  ( Sing-  , SingI(..)-  , SomeSing(..)-#if !MIN_VERSION_singletons(2,2,0)-  , KProxy(..)-#endif-  )-import Data.Singletons.Prelude (Sing(..))-#if MIN_VERSION_singletons(2,4,0)-import Data.Singletons.ShowSing (ShowSing(..))-#endif-import Data.Singletons.TypeLits (KnownSymbol, symbolVal)-import Data.Word-import Foreign.C (CChar)-import Foreign.ForeignPtr-  ( ForeignPtr-  , castForeignPtr-  , newForeignPtr_-  , withForeignPtr-  )-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Foreign.JNI.Internal-import Foreign.JNI.NativeMethod-import qualified Foreign.JNI.String as JNI-import Foreign.Marshal.Alloc (allocaBytesAligned)-import Foreign.Ptr-import Foreign.Storable (Storable(..))-import GHC.TypeLits (Symbol)-import Language.C.Types (TypeSpecifier(TypeName))-import Language.C.Inline.Context (Context(..), fptrCtx)-import System.IO.Unsafe (unsafePerformIO)---- | A JVM instance.-newtype JVM = JVM_ (Ptr JVM)-  deriving (Eq, Show, Storable, NFData)---- | The thread-local JNI context. Do not share this object between threads.-newtype JNIEnv = JNIEnv_ (Ptr JNIEnv)-  deriving (Eq, Show, Storable, NFData)---- | A thread-local reference to a field of an object.-newtype JFieldID = JFieldID_ (Ptr JFieldID)-  deriving (Eq, Show, Storable, NFData)---- | A thread-local reference to a method of an object.-newtype JMethodID = JMethodID_ (Ptr JMethodID)-  deriving (Eq, Show, Storable, NFData)---- | Not part of the JNI. The kind of 'J' type indices. Useful to reflect the--- object's class at the type-level.-data JType-  = Class Symbol                               -- ^ Class name-  | Iface Symbol                               -- ^ Interface name-  | Prim Symbol                                -- ^ Primitive type-  | Array JType                                -- ^ Array type-  | Generic JType [JType]                      -- ^ Parameterized (generic) type-  | Void                                       -- ^ Void special type---- | The class of Java types that are "unboxed".-class SingI ty => IsPrimitiveType (ty :: JType)-instance KnownSymbol sym => IsPrimitiveType ('Prim sym)--class IsReferenceType (ty :: JType)-instance IsReferenceType ('Class sym)-instance IsReferenceType ('Iface sym)-instance IsReferenceType ('Array ty)-instance IsReferenceType ty => IsReferenceType ('Generic ty tys)---- | Produces evidence for IsReferenceType from a `Sing ty`.-singToIsReferenceType :: Sing (ty :: JType) -> Maybe (Dict (IsReferenceType ty))-singToIsReferenceType tysing = case tysing of-    SClass _ -> Just Dict-    SPrim _ -> Nothing-    SIface _ -> Just Dict-    SArray _ -> Just Dict-    SGeneric tysing' _ -> (\Dict -> Dict) <$> singToIsReferenceType tysing'-    SVoid -> Nothing--data instance Sing (a :: JType) where-  -- Using String instead of JNI.String for the singleton data constructors-  -- is an optimization. Otherwise, the comparisons in Language.Java.call-  -- and callStatic would involve allocations and cannot be cached.-  ---  -- See commit 3da51a4 and https://github.com/tweag/inline-java/issues/11-  SClass :: String -> Sing ('Class sym)-  SIface :: String -> Sing ('Iface sym)-  SPrim :: String -> Sing ('Prim sym)-  SArray :: Sing ty -> Sing ('Array ty)-  SGeneric :: Sing ty -> Sing tys -> Sing ('Generic ty tys)-  SVoid :: Sing 'Void--realShowsPrec :: Show a => Int -> a -> ShowS-realShowsPrec = showsPrec--#if MIN_VERSION_singletons(2,4,0)--instance Show (Sing (a :: JType)) where-  showsPrec = showsSingPrec---- The instance of Show and ShowSing for JType singletons--- is reused by adjusting the method name with a macro--- definition.-#define showsPrec showsSingPrec-instance ShowSing JType where-#else--instance Show (Sing (a :: [JType])) where-  showsPrec _ SNil = showString "SNil"-  showsPrec d (SCons ty tys) = showParen (d > 10) $-      showString "SCons " . showsPrec 11 ty . showChar ' ' . showsPrec 11 tys--instance Show (Sing (a :: JType)) where-#endif-  showsPrec d (SClass s) = showParen (d > 10) $-      showString "SClass " . realShowsPrec 11 s-  showsPrec d (SIface s) = showParen (d > 10) $-      showString "SIface " . realShowsPrec 11 s-  showsPrec d (SPrim s) = showParen (d > 10) $-      showString "SPrim " . realShowsPrec 11 s-  showsPrec d (SArray s) = showParen (d > 10) $-      showString "SArray " . showsPrec 11 s-  showsPrec d (SGeneric s sargs) = showParen (d > 10) $-      showString "SGeneric " . showsPrec 11 s . showsPrec 11 sargs-  showsPrec _ SVoid = showString "SVoid"--#undef showsPrec---- XXX SingI constraint temporary hack because GHC 7.10 has trouble inferring--- this constraint in 'signature'.-instance (KnownSymbol sym, SingI sym) => SingI ('Class (sym :: Symbol)) where-  sing = SClass $ symbolVal (undefined :: proxy sym)-instance (KnownSymbol sym, SingI sym) => SingI ('Iface (sym :: Symbol)) where-  sing = SIface $ symbolVal (undefined :: proxy sym)-instance (KnownSymbol sym, SingI sym) => SingI ('Prim (sym :: Symbol)) where-  sing = SPrim $ symbolVal (undefined :: proxy sym)-instance SingI ty => SingI ('Array ty) where-  sing = SArray sing-instance (SingI ty, SingI tys) => SingI ('Generic ty tys) where-  sing = SGeneric sing sing-instance SingI 'Void where-  sing = SVoid---- | Shorthand for parametized Java types.-type a <> g = 'Generic a g---- | Type indexed Java Objects.-newtype J (a :: JType) = J (ForeignPtr (J a))-  deriving (Eq, Show)--type role J representational---- | The null reference.-jnull :: J a-jnull = J $ unsafePerformIO $ newForeignPtr_ nullPtr---- | Any object can be cast to @Object@.-upcast :: J a -> JObject-upcast = unsafeCast---- | Any array of a reference type can be casted to an array of @Object@s.-arrayUpcast :: IsReferenceType ty => J ('Array ty) -> JObjectArray-arrayUpcast = unsafeCast---- | Unsafe type cast. Should only be used to downcast.-unsafeCast :: J a -> J b-unsafeCast (J x) = J (castForeignPtr x)---- | Parameterize the type of an object, making its type a /generic type/.-generic :: J a -> J (a <> g)-generic = unsafeCast---- | Get the base type of a generic type.-unsafeUngeneric :: J (a <> g) -> J a-unsafeUngeneric = unsafeCast---- | A union type for uniformly passing arguments to methods.-data JValue-  = JBoolean Word8-  | JByte CChar-  | JChar Word16-  | JShort Int16-  | JInt Int32-  | JLong Int64-  | JFloat Float-  | JDouble Double-  | forall a. SingI a => JObject {-# UNPACK #-} !(J a)--instance Show JValue where-  show (JBoolean x) = "JBoolean " ++ show x-  show (JByte x) = "JByte " ++ show x-  show (JChar x) = "JChar " ++ show x-  show (JShort x) = "JShort " ++ show x-  show (JInt x) = "JInt " ++ show x-  show (JLong x) = "JLong " ++ show x-  show (JFloat x) = "JFloat " ++ show x-  show (JDouble x) = "JDouble " ++ show x-  show (JObject x) = "JObject " ++ show x--instance Eq JValue where-  (JBoolean x) == (JBoolean y) = x == y-  (JByte x) == (JByte y) = x == y-  (JChar x) == (JChar y) = x == y-  (JShort x) == (JShort y) = x == y-  (JInt x) == (JInt y) = x == y-  (JLong x) == (JLong y) = x == y-  (JFloat x) == (JFloat y) = x == y-  (JDouble x) == (JDouble y) = x == y-  (JObject (J x)) == (JObject (J y)) = castForeignPtr x == castForeignPtr y-  _ == _ = False--sizeOfJValue, alignmentJValue :: Int-sizeOfJValue      = 8-alignmentJValue   = 8---- | @withJValue jvalues f@ provides a pointer to an array containing the given--- @jvalues@.------ The array is valid only while evaluating @f@.-withJValues :: [JValue] -> (Ptr JValue -> IO a) -> IO a-withJValues args f =-    allocaBytesAligned (sizeOfJValue * length args) alignmentJValue $ \p ->-      foldr (.) id (zipWith (withJValueOff p) [0..] args) (f p)---- @withJValueOff p n jvalue io@ writes the given @jvalue@ to @p `plusPtr` n@--- and runs @io@.------ The jvalue is guaranteed to stay valid while @io@ evaluates.-withJValueOff :: Ptr JValue -> Int -> JValue -> IO a -> IO a-withJValueOff p n jvalue io = case jvalue of-    JBoolean x -> pokeByteOff (castPtr p) offset x >> io-    JByte    x -> pokeByteOff (castPtr p) offset x >> io-    JChar    x -> pokeByteOff (castPtr p) offset x >> io-    JShort   x -> pokeByteOff (castPtr p) offset x >> io-    JInt     x -> pokeByteOff (castPtr p) offset x >> io-    JLong    x -> pokeByteOff (castPtr p) offset x >> io-    JFloat   x -> pokeByteOff (castPtr p) offset x >> io-    JDouble  x -> pokeByteOff (castPtr p) offset x >> io--    JObject (J x) -> withForeignPtr x $ \xp ->-      pokeByteOff (castPtr p) offset xp >> io-  where-    offset = n * sizeOfJValue---- | Get the Java type of a value.-#if MIN_VERSION_singletons(2,2,0)-jtypeOf :: JValue -> SomeSing JType-#else-jtypeOf :: JValue -> SomeSing ('KProxy :: KProxy JType)-#endif-jtypeOf (JBoolean _) = SomeSing (sing :: Sing ('Prim "boolean"))-jtypeOf (JByte _) = SomeSing (sing :: Sing ('Prim "byte"))-jtypeOf (JChar _) = SomeSing (sing :: Sing ('Prim "char"))-jtypeOf (JShort _) = SomeSing (sing :: Sing ('Prim "short"))-jtypeOf (JInt _) = SomeSing (sing :: Sing ('Prim "int"))-jtypeOf (JLong _) = SomeSing (sing :: Sing ('Prim "long"))-jtypeOf (JFloat _) = SomeSing (sing :: Sing ('Prim "float"))-jtypeOf (JDouble _) = SomeSing (sing :: Sing ('Prim "double"))-jtypeOf (JObject (_ :: J ty)) = SomeSing (sing :: Sing ty)---- | Create a null-terminated string.-build :: Builder -> JNI.String-build =-  JNI.unsafeFromByteString .-  BSL.toStrict .-  Builder.toLazyByteString .-  (<> Builder.char7 '\NUL')---- | The name of a type, suitable for passing to 'Foreign.JNI.findClass'.-referenceTypeName :: IsReferenceType ty => Sing (ty :: JType) -> ReferenceTypeName-referenceTypeName (SClass sym) = ReferenceTypeName $ build $ classSymbolBuilder sym-referenceTypeName (SIface sym) = ReferenceTypeName $ build $ classSymbolBuilder sym-referenceTypeName ty@(SArray _) = ReferenceTypeName $ build $ signatureBuilder ty-referenceTypeName (SGeneric ty@(SClass _) _) = referenceTypeName ty-referenceTypeName (SGeneric ty@(SIface _) _) = referenceTypeName ty-referenceTypeName _ = error "referenceTypeName: Impossible."--classSymbolBuilder :: String -> Builder-classSymbolBuilder sym =-    Prim.primMapByteStringFixed (subst Prim.>$< Prim.word8)-      (JNI.toByteString $ JNI.fromChars sym)-  where-    subst (chr . fromIntegral -> '.') = fromIntegral (ord '/')-    subst x = x--signatureBuilder :: Sing (ty :: JType) -> Builder-signatureBuilder (SClass sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';'-signatureBuilder (SIface sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';'-signatureBuilder (SPrim "boolean") = Builder.char7 'Z'-signatureBuilder (SPrim "byte") = Builder.char7 'B'-signatureBuilder (SPrim "char") = Builder.char7 'C'-signatureBuilder (SPrim "short") = Builder.char7 'S'-signatureBuilder (SPrim "int") = Builder.char7 'I'-signatureBuilder (SPrim "long") = Builder.char7 'J'-signatureBuilder (SPrim "float") = Builder.char7 'F'-signatureBuilder (SPrim "double") = Builder.char7 'D'-signatureBuilder (SPrim sym) = error $ "Unknown primitive: " ++ sym-signatureBuilder (SArray ty) = Builder.char7 '[' <> signatureBuilder ty-signatureBuilder (SGeneric ty _) = signatureBuilder ty-signatureBuilder SVoid = Builder.char7 'V'---- | Construct a JNI type signature from a Java type.-signature :: Sing (ty :: JType) -> Signature-signature = Signature . build . signatureBuilder---- | Construct a method's JNI type signature, given the type of the arguments--- and the return type.-methodSignature-#if MIN_VERSION_singletons(2,2,0)-  :: [SomeSing JType]-#else-  :: [SomeSing ('KProxy :: KProxy JType)]-#endif-  -> Sing (ty :: JType)-  -> MethodSignature-methodSignature args ret =-    MethodSignature $-    build $-    Builder.char7 '(' <>-    mconcat (map (\(SomeSing s) -> signatureBuilder s) args) <>-    Builder.char7 ')' <>-    signatureBuilder ret---- | Turn the raw pointer into an object.-objectFromPtr :: Ptr (J a) -> IO (J a)-objectFromPtr ptr = J <$> newForeignPtr_ ptr---- | Get a raw pointer to an object. This is unsafe because if the argument is--- the last usage occurrence of the given foreign pointer, then its finalizer(s)--- will be run, which potentially invalidates the plain pointer just obtained.-unsafeObjectToPtr :: J a -> Ptr (J a)-unsafeObjectToPtr (J fptr) = unsafeForeignPtrToPtr fptr--type JObject = J ('Class "java.lang.Object")-type JClass = J ('Class "java.lang.Class")-type JString = J ('Class "java.lang.String")-type JThrowable = J ('Class "java.lang.Throwable")-type JArray a = J ('Array a)-type JObjectArray = JArray ('Class "java.lang.Object")-type JBooleanArray = JArray ('Prim "boolean")-type JByteArray = JArray ('Prim "byte")-type JCharArray = JArray ('Prim "char")-type JShortArray = JArray ('Prim "short")-type JIntArray = JArray ('Prim "int")-type JLongArray = JArray ('Prim "long")-type JFloatArray = JArray ('Prim "float")-type JDoubleArray = JArray ('Prim "double")--jniCtx :: Context-jniCtx = mempty { ctxTypesTable = Map.fromList tytab } <> fptrCtx-  where-    tytab =-      [ -- Primitive types-        (TypeName "jboolean", [t| Word8 |])-      , (TypeName "jbyte", [t| CChar |])-      , (TypeName "jchar", [t| Word16 |])-      , (TypeName "jshort", [t| Int16 |])-      , (TypeName "jint", [t| Int32 |])-      , (TypeName "jlong", [t| Int64 |])-      , (TypeName "jfloat", [t| Float |])-      , (TypeName "jdouble", [t| Double |])-      -- Reference types-      , (TypeName "jobject", [t| Ptr JObject |])-      , (TypeName "jclass", [t| Ptr JClass |])-      , (TypeName "jstring", [t| Ptr JString |])-      , (TypeName "jarray", [t| Ptr JObject |])-      , (TypeName "jobjectArray", [t| Ptr JObjectArray |])-      , (TypeName "jbooleanArray", [t| Ptr JBooleanArray |])-      , (TypeName "jbyteArray", [t| Ptr JByteArray |])-      , (TypeName "jcharArray", [t| Ptr JCharArray |])-      , (TypeName "jshortArray", [t| Ptr JShortArray |])-      , (TypeName "jintArray", [t| Ptr JIntArray |])-      , (TypeName "jlongArray", [t| Ptr JLongArray |])-      , (TypeName "jfloatArray", [t| Ptr JFloatArray |])-      , (TypeName "jdoubleArray", [t| Ptr JDoubleArray |])-      , (TypeName "jthrowable", [t| Ptr JThrowable |])-      -- Internal types-      , (TypeName "JavaVM", [t| JVM |])-      , (TypeName "JNIEnv", [t| JNIEnv |])-      , (TypeName "JNINativeMethod", [t| JNINativeMethod |])-      , (TypeName "jfieldID", [t| JFieldID |])-      , (TypeName "jmethodID", [t| JMethodID |])-      , (TypeName "jsize", [t| Int32 |])-      , (TypeName "jvalue", [t| JValue |])-      ]
+ src/common/Foreign/JNI.hs view
@@ -0,0 +1,4 @@+-- | Reexports definitions from "Foreign.JNI.Unsafe".+module Foreign.JNI (module Foreign.JNI.Unsafe) where++import Foreign.JNI.Unsafe
+ src/common/Foreign/JNI/Internal.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Foreign.JNI.Internal where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Foreign.JNI.String as JNI++-- | A reference type name is not just any 'JNI.String', but a fully qualified+-- identifier well-formed by construction.+newtype ReferenceTypeName = ReferenceTypeName JNI.String+  deriving (Eq, Ord)++instance Show ReferenceTypeName where+  show (ReferenceTypeName str) = show str++-- | A string representing a signature, well-formed by construction.+newtype Signature = Signature JNI.String+  deriving (Eq, Ord)++instance Show Signature where+  show (Signature str) = show str++-- | A string representing a method signature, well-formed by construction.+newtype MethodSignature = MethodSignature JNI.String+  deriving (Eq, Ord)++instance Show MethodSignature where+  show (MethodSignature str) = show str++jniMethodToJavaSignature :: Text -> Either String ([Text], Text)+jniMethodToJavaSignature sig = do+    (argTypes, rest1) <- dropChar '(' sig >>= many toJavaType+    (returnType, rest2) <- dropChar ')' rest1 >>= toJavaType+    if Text.null rest2 then return (argTypes, returnType)+    else Left $ "Unexpected suffix " ++ show rest2+  where+    dropChar c t = case Text.uncons t of+      Just (c', t') | c == c' -> Right t'+      _ -> Left $ unwords+              [ "Expected ", show c, "but found", show t]+    many p = go id+      where+        go acc t = case p t of+          Left _ -> Right (acc [], t)+          Right (x, t') -> go (acc . (x:)) t'+    toJavaType t = case Text.uncons t of+      Just (c, t') ->+        case c of+          'L' -> case Text.breakOn ";" t' of+            (jtype, rest) -> Right (Text.map substSlash jtype, Text.drop 1 rest)+          '[' ->+            fmap (\(jtype, rest) -> (jtype <> "[]", rest)) (toJavaType t')+          'Z' -> Right ("boolean", t')+          'B' -> Right ("byte", t')+          'C' -> Right ("char", t')+          'S' -> Right ("short", t')+          'I' -> Right ("int", t')+          'J' -> Right ("long", t')+          'F' -> Right ("float", t')+          'D' -> Right ("double", t')+          'V' -> Right ("void", t')+          _ -> Left $ "Unexpected char " ++ show c ++ " at " ++ show t'+      Nothing ->+        Left "Unexpected empty text"+    substSlash = \case+      '/' -> '.'+      c -> c
+ src/common/Foreign/JNI/Internal/BackgroundWorker.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+module Foreign.JNI.Internal.BackgroundWorker+  ( BackgroundWorker+  , create+  , setQueueSize+  , stop+  , submitTask+  ) where++import Control.Concurrent.Async (Async, async, waitCatch)+import Control.Concurrent.STM+  (TVar, atomically, modifyTVar', newTVarIO, readTVar, retry, writeTVar)+import Control.Exception (Exception, handle, throwIO, uninterruptibleMask_)+import Control.Monad (forever, join, void)+++-- | A background thread that can run tasks asynchronously+data BackgroundWorker = BackgroundWorker+  { nextBatchRef :: TVar Batch+  , queueSizeRef :: TVar Int+  , workerAsync :: Async ()+  }++-- | Creates a background worker that starts running immediately.+--+-- Takes a function that can initialize the thread before entering+-- the main loop.+--+create :: (IO () -> IO ()) -> IO BackgroundWorker+create runInInitializedThread = do+    queueSizeRef <- newTVarIO defaultQueueSize+    nextBatchRef <- newTVarIO emptyBatch+    workerAsync <- async $ runInInitializedThread $ handleTermination $+      forever (runNextBatch nextBatchRef)+    return BackgroundWorker+      { nextBatchRef+      , queueSizeRef+      , workerAsync+      }+  where+    handleTermination = handle $ \StopWorkerException -> return ()+    runNextBatch nextBatchRef =+      join $ atomically $ do+        nextBatch <- readTVar nextBatchRef+        case getTasks nextBatch of+          Just tasks -> tasks <$ writeTVar nextBatchRef emptyBatch+          Nothing -> retry++defaultQueueSize :: Int+defaultQueueSize = 1024 * 1024++-- | Set the maximum number of pending tasks+setQueueSize :: BackgroundWorker -> Int -> IO ()+setQueueSize (BackgroundWorker {queueSizeRef}) n =+  if n > 0+  then atomically $ writeTVar queueSizeRef n+  else error ("The queue size must be a positive number. Tried " ++ show n)++data StopWorkerException = StopWorkerException+  deriving Show++instance Exception StopWorkerException++-- | Stops the background worker and waits until it terminates.+stop :: BackgroundWorker -> IO ()+stop (BackgroundWorker {nextBatchRef, workerAsync}) =+  uninterruptibleMask_ $ do+    submitStopAtEndOfBatch+    void $ waitCatch workerAsync+  where+    submitStopAtEndOfBatch = do+      let task = throwIO StopWorkerException+      atomically $ modifyTVar' nextBatchRef (snocTask task)++-- | Submits a task to the background worker.+--+-- Any exception thrown in the given task will stop the+-- background thread.+--+-- If the job queue is currently full, block until it isn't.+--+submitTask :: BackgroundWorker -> IO () -> IO ()+submitTask (BackgroundWorker {nextBatchRef, queueSizeRef}) task = do+  atomically $ do+    queueSize <- readTVar queueSizeRef+    nextBatch <- readTVar nextBatchRef+    if getBatchSize nextBatch < queueSize then+      writeTVar nextBatchRef (consTask task nextBatch)+    else+      retry++-- | A batch of tasks+--+-- Contains the task count and the computation that performs+-- all the tasks.+newtype Batch = Batch (Int, IO ())++emptyBatch :: Batch+emptyBatch = Batch (0, return ())++consTask :: IO () -> Batch -> Batch+consTask task (Batch (n, tasks)) = Batch (n + 1, task >> tasks)++snocTask :: IO () -> Batch -> Batch+snocTask task (Batch (n, tasks)) = Batch (n + 1, tasks >> task)++-- | Yields Nothing on an empty batch.+getTasks :: Batch -> Maybe (IO ())+getTasks (Batch (0, _)) = Nothing+getTasks (Batch (_, tasks)) = Just tasks++getBatchSize :: Batch -> Int+getBatchSize (Batch (n, _)) = n
+ src/common/Foreign/JNI/Internal/RWLock.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+module Foreign.JNI.Internal.RWLock+  ( RWLock+  , new+  , tryAcquireReadLock+  , releaseReadLock+  , acquireWriteLock+  ) where++import Control.Concurrent.STM+  (TVar, atomically, check, newTVarIO, readTVar, stateTVar, writeTVar)+import Control.Monad (when)+import Data.Choice+++-- | A read-write lock+--+-- Concurrent readers are allowed, but only one writer is supported.+--+-- Moreover, a writer trying to acquire a write lock has priority over+-- new readers trying to acquire a read lock.+newtype RWLock =+    RWLock (TVar (Int, RWWantedState))+    -- ^ A count of the held read locks and the wanted state++-- | The wanted state of the RW+data RWWantedState+    = Reading             -- ^ There are no writers+    | Writing (TVar Bool) -- ^ A writer wants to write, grant no more read locks.+                          -- The TVar is to be written when the last read lock+                          -- is released.++-- | Creates a new read-write lock.+new :: IO RWLock+new = RWLock <$> newTVarIO (0, Reading)++-- | Tries to acquire a read lock. If this call returns `Do #read`, no writer+-- will be granted a lock before the read lock is released. The lock can be+-- denied if a writer is writing or waiting to write.+tryAcquireReadLock :: RWLock -> IO (Choice "read")+tryAcquireReadLock (RWLock ref) = atomically $+    readTVar ref >>= \case+      (!readers, Reading) -> do+        writeTVar ref (readers + 1, Reading)+        return $ Do #read+      _ -> return $ Don't #read++-- | Releases a read lock.+releaseReadLock :: RWLock -> IO ()+releaseReadLock (RWLock ref) =+    atomically $ do+      (readers, aim) <- readTVar ref+      writeTVar ref (readers - 1, aim)+      case (readers, aim) of+        (1, Writing noReadersRef) -> writeTVar noReadersRef True+        _ -> return ()++-- | Waits until the current read locks are released and grants a write lock.+-- No new reader locks are granted while the writer is waiting for the lock+-- and while it holds the write lock.+acquireWriteLock :: RWLock -> IO ()+acquireWriteLock (RWLock ref) = do+    noReadersRef <- newTVarIO False+    readers <- atomically $ stateTVar ref $ \(readers, _) ->+      (readers, (readers, Writing noReadersRef))+    when (readers > 0) $ atomically $+      readTVar noReadersRef >>= check
+ src/common/Foreign/JNI/NativeMethod.hsc view
@@ -0,0 +1,42 @@+-- | Bindings to the JNINativeMethod struct.++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}++module Foreign.JNI.NativeMethod where++import qualified Data.ByteString.Unsafe as BS+import Data.Coerce (coerce)+import Foreign.JNI.Internal+import qualified Foreign.JNI.String as JNI+import Foreign.Ptr (FunPtr)+import Foreign.Storable (Storable(..))++#include <jni.h>++#if __GLASGOW_HASKELL__ < 800+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++data JNINativeMethod = forall a. JNINativeMethod+  { jniNativeMethodName :: JNI.String+  , jniNativeMethodSignature :: MethodSignature+  , jniNativeMethodFunPtr :: FunPtr a+  }++instance Storable JNINativeMethod where+  sizeOf _ = #{size JNINativeMethod}+  alignment _ = #{alignment JNINativeMethod}+  peek ptr = do+      name <- BS.unsafePackCString =<< #{peek JNINativeMethod, name} ptr+      sig <- BS.unsafePackCString =<< #{peek JNINativeMethod, signature} ptr+      fptr <- #{peek JNINativeMethod, fnPtr} ptr+      return $+        JNINativeMethod+          (JNI.unsafeFromByteString name)+          (coerce (JNI.unsafeFromByteString sig))+          fptr+  poke ptr JNINativeMethod{..} = do+      JNI.withString jniNativeMethodName $ #{poke JNINativeMethod, name} ptr+      JNI.withString (coerce jniNativeMethodSignature) $ #{poke JNINativeMethod, signature} ptr+      #{poke JNINativeMethod, fnPtr} ptr jniNativeMethodFunPtr
+ src/common/Foreign/JNI/String.hs view
@@ -0,0 +1,75 @@+-- | JNI strings. Like C strings and unlike 'Data.ByteString.ByteString', these+-- are null-terminated. Unlike C strings, each character is (multi-byte) encoded+-- as UTF-8. Unlike UTF-8, embedded NULL characters are encoded as two bytes and+-- the four-byte UTF-8 format for characters is not recognized. A custom+-- encoding is used instead. See+-- <http://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/types.html#modified_utf_8_strings>+-- for more details.+--+-- /NOTE:/ the current implementation does not support embedded NULL's and+-- four-byte characters.++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MagicHash #-}++module Foreign.JNI.String+  ( String+  , toChars+  , fromChars+  , fromByteString+  , unsafeFromByteString+  , toByteString+  , withString+  ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import Data.ByteString (ByteString)+import Data.String (IsString(..))+import Foreign.C.String (CString)+import qualified GHC.Foreign as GHC+import qualified GHC.IO.Encoding as GHC+import System.IO.Unsafe (unsafeDupablePerformIO)+import qualified Prelude+import Prelude hiding (String)++-- A JNI string is represented as a NUL terminated bytestring in UTF-8 encoding.+newtype String = String ByteString+  deriving (Eq, Ord)++instance Show String where+  show str = show (toChars str)++instance IsString String where+  fromString str = fromChars str++fromChars :: Prelude.String -> String+{-# INLINE [0] fromChars #-}+fromChars str = unsafeDupablePerformIO $+    GHC.withCString GHC.utf8 str $ \cstr -> do+      -- we need to copy the trailing NUL+      len <- BS.c_strlen cstr+      String <$> BS.packCStringLen (cstr, fromIntegral len + 1)++toChars :: String -> Prelude.String+toChars (String bs) = unsafeDupablePerformIO $ BS.unsafeUseAsCString bs $ GHC.peekCString GHC.utf8++withString :: String -> (CString -> IO a) -> IO a+withString (String bs) f = BS.unsafeUseAsCString bs f++-- Discards the trailing NUL.+toByteString :: String -> ByteString+toByteString (String bs) = BS.init bs++-- | O(1) if the input is null-terminated. Otherwise the input is copied into+-- a null-terminated buffer first.+fromByteString :: ByteString -> String+fromByteString bs+  | BS.length bs > 0 && BS.last bs == 0 = String bs+  | otherwise = String (bs `BS.snoc` 0)++-- | Same as 'fromByteString', but doesn't check whether the input is+-- null-terminated or not.+unsafeFromByteString :: ByteString -> String+unsafeFromByteString = String
+ src/common/Foreign/JNI/Types.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Foreign.JNI.Types+  ( JType(..)+  , IsPrimitiveType+  , IsReferenceType+  , Sing+  , SJType(..)+  , type (<>)+    -- * JNI types+  , J(..)+  , jnull+  , upcast+  , arrayUpcast+  , unsafeCast+  , generic+  , unsafeUngeneric+  , jtypeOf+  , ReferenceTypeName+  , singToIsReferenceType+  , referenceTypeName+  , Signature+  , signature+  , MethodSignature+  , methodSignature+  , JVM(..)+  , JNIEnv(..)+  , JMethodID(..)+  , JFieldID(..)+  , JValue(..)+  , withJValues+    -- * Conversions+  , objectFromPtr+  , unsafeObjectToPtr+    -- * JNI defined object types+  , JObject+  , JClass+  , JString+  , JArray+  , JObjectArray+  , JBooleanArray+  , JByteArray+  , JCharArray+  , JShortArray+  , JIntArray+  , JLongArray+  , JFloatArray+  , JDoubleArray+  , JThrowable+  , JByteBuffer+  -- * inline-c contexts+  , jniCtx+  ) where++import Control.DeepSeq (NFData)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Prim as Prim+import Data.ByteString.Builder (Builder)+import Data.Char (chr, ord)+import Data.Constraint (Dict(..))+import Data.Int+import qualified Data.Map as Map+import Data.Singletons+import Data.Word+import Foreign.C (CChar)+import Foreign.ForeignPtr+  ( ForeignPtr+  , castForeignPtr+  , newForeignPtr_+  , withForeignPtr+  )+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.JNI.Internal+import Foreign.JNI.NativeMethod+import qualified Foreign.JNI.String as JNI+import Foreign.Marshal.Alloc (allocaBytesAligned)+import Foreign.Ptr+import Foreign.Storable (Storable(..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Language.C.Types (TypeSpecifier(TypeName))+import Language.C.Inline.Context (Context(..), fptrCtx)+import System.IO.Unsafe (unsafePerformIO)++-- | A JVM instance.+newtype JVM = JVM_ (Ptr JVM)+  deriving (Eq, Show, Storable, NFData)++-- | The thread-local JNI context. Do not share this object between threads.+newtype JNIEnv = JNIEnv_ (Ptr JNIEnv)+  deriving (Eq, Show, Storable, NFData)++-- | A thread-local reference to a field of an object.+newtype JFieldID = JFieldID_ (Ptr JFieldID)+  deriving (Eq, Show, Storable, NFData)++-- | A thread-local reference to a method of an object.+newtype JMethodID = JMethodID_ (Ptr JMethodID)+  deriving (Eq, Show, Storable, NFData)++-- | Not part of the JNI. The kind of 'J' type indices. Useful to reflect the+-- object's class at the type-level.+data JType+  = Class Symbol                               -- ^ Class name+  | Iface Symbol                               -- ^ Interface name+  | Prim Symbol                                -- ^ Primitive type+  | Array JType                                -- ^ Array type+  | Generic JType [JType]                      -- ^ Parameterized (generic) type+  | Void                                       -- ^ Void special type++-- | The class of Java types that are "unboxed".+class SingI ty => IsPrimitiveType (ty :: JType)+instance KnownSymbol sym => IsPrimitiveType ('Prim sym)++class IsReferenceType (ty :: JType)+instance IsReferenceType ('Class sym)+instance IsReferenceType ('Iface sym)+instance IsReferenceType ('Array ty)+instance IsReferenceType ty => IsReferenceType ('Generic ty tys)++-- | Produces evidence for IsReferenceType from a `Sing ty`.+singToIsReferenceType :: Sing (ty :: JType) -> Maybe (Dict (IsReferenceType ty))+singToIsReferenceType tysing = case tysing of+    SClass _ -> Just Dict+    SPrim _ -> Nothing+    SIface _ -> Just Dict+    SArray _ -> Just Dict+    SGeneric tysing' _ -> (\Dict -> Dict) <$> singToIsReferenceType tysing'+    SVoid -> Nothing++type instance Sing = SJType+data SJType (a :: JType) where+  -- Using String instead of JNI.String for the singleton data constructors+  -- is an optimization. Otherwise, the comparisons in Language.Java.call+  -- and callStatic would involve allocations and cannot be cached.+  --+  -- See commit 3da51a4 and https://github.com/tweag/inline-java/issues/11+  SClass :: String -> SJType ('Class sym)+  SIface :: String -> SJType ('Iface sym)+  SPrim :: String -> SJType ('Prim sym)+  SArray :: SJType ty -> SJType ('Array ty)+  SGeneric :: SJType ty -> Sing tys -> SJType ('Generic ty tys)+  SVoid :: SJType 'Void++realShowsPrec :: Show a => Int -> a -> ShowS+realShowsPrec = showsPrec++instance Show (SJType a) where+  showsPrec d (SClass s) = showParen (d > 10) $+      showString "SClass " . realShowsPrec 11 s+  showsPrec d (SIface s) = showParen (d > 10) $+      showString "SIface " . realShowsPrec 11 s+  showsPrec d (SPrim s) = showParen (d > 10) $+      showString "SPrim " . realShowsPrec 11 s+  showsPrec d (SArray s) = showParen (d > 10) $+      showString "SArray " . showsPrec 11 s+  showsPrec d (SGeneric s sargs) = showParen (d > 10) $+      showString "SGeneric " . showsPrec 11 s . showsPrec 11 sargs+  showsPrec _ SVoid = showString "SVoid"++-- XXX SingI constraint temporary hack because GHC 7.10 has trouble inferring+-- this constraint in 'signature'.+instance (KnownSymbol sym, SingI sym) => SingI ('Class (sym :: Symbol)) where+  sing = SClass $ symbolVal (undefined :: proxy sym)+instance (KnownSymbol sym, SingI sym) => SingI ('Iface (sym :: Symbol)) where+  sing = SIface $ symbolVal (undefined :: proxy sym)+instance (KnownSymbol sym, SingI sym) => SingI ('Prim (sym :: Symbol)) where+  sing = SPrim $ symbolVal (undefined :: proxy sym)+instance SingI ty => SingI ('Array ty) where+  sing = SArray (sing @ty)+instance (SingI ty, SingI tys) => SingI ('Generic ty tys) where+  sing = SGeneric (sing @ty) (sing @tys)+instance SingI 'Void where+  sing = SVoid++-- | Shorthand for parametized Java types.+type a <> g = 'Generic a g++-- | Type indexed Java Objects.+newtype J (a :: JType) = J (ForeignPtr (J a))+  deriving (Eq, Show)++type role J representational++-- | The null reference.+jnull :: J a+jnull = J $ unsafePerformIO $ newForeignPtr_ nullPtr++-- | Any object can be cast to @Object@.+upcast :: J a -> JObject+upcast = unsafeCast++-- | Any array of a reference type can be casted to an array of @Object@s.+arrayUpcast :: IsReferenceType ty => J ('Array ty) -> JObjectArray+arrayUpcast = unsafeCast++-- | Unsafe type cast. Should only be used to downcast.+unsafeCast :: J a -> J b+unsafeCast (J x) = J (castForeignPtr x)++-- | Parameterize the type of an object, making its type a /generic type/.+generic :: J a -> J (a <> g)+generic = unsafeCast++-- | Get the base type of a generic type.+unsafeUngeneric :: J (a <> g) -> J a+unsafeUngeneric = unsafeCast++-- | A union type for uniformly passing arguments to methods.+data JValue+  = JBoolean Word8+  | JByte CChar+  | JChar Word16+  | JShort Int16+  | JInt Int32+  | JLong Int64+  | JFloat Float+  | JDouble Double+  | forall a. SingI a => JObject {-# UNPACK #-} !(J a)++instance Show JValue where+  show (JBoolean x) = "JBoolean " ++ show x+  show (JByte x) = "JByte " ++ show x+  show (JChar x) = "JChar " ++ show x+  show (JShort x) = "JShort " ++ show x+  show (JInt x) = "JInt " ++ show x+  show (JLong x) = "JLong " ++ show x+  show (JFloat x) = "JFloat " ++ show x+  show (JDouble x) = "JDouble " ++ show x+  show (JObject x) = "JObject " ++ show x++instance Eq JValue where+  (JBoolean x) == (JBoolean y) = x == y+  (JByte x) == (JByte y) = x == y+  (JChar x) == (JChar y) = x == y+  (JShort x) == (JShort y) = x == y+  (JInt x) == (JInt y) = x == y+  (JLong x) == (JLong y) = x == y+  (JFloat x) == (JFloat y) = x == y+  (JDouble x) == (JDouble y) = x == y+  (JObject (J x)) == (JObject (J y)) = castForeignPtr x == castForeignPtr y+  _ == _ = False++sizeOfJValue, alignmentJValue :: Int+sizeOfJValue      = 8+alignmentJValue   = 8++-- | @withJValue jvalues f@ provides a pointer to an array containing the given+-- @jvalues@.+--+-- The array is valid only while evaluating @f@.+withJValues :: [JValue] -> (Ptr JValue -> IO a) -> IO a+withJValues args f =+    allocaBytesAligned (sizeOfJValue * length args) alignmentJValue $ \p ->+      foldr (.) id (zipWith (withJValueOff p) [0..] args) (f p)++-- @withJValueOff p n jvalue io@ writes the given @jvalue@ to @p `plusPtr` n@+-- and runs @io@.+--+-- The jvalue is guaranteed to stay valid while @io@ evaluates.+withJValueOff :: Ptr JValue -> Int -> JValue -> IO a -> IO a+withJValueOff p n jvalue io = case jvalue of+    JBoolean x -> pokeByteOff (castPtr p) offset x >> io+    JByte    x -> pokeByteOff (castPtr p) offset x >> io+    JChar    x -> pokeByteOff (castPtr p) offset x >> io+    JShort   x -> pokeByteOff (castPtr p) offset x >> io+    JInt     x -> pokeByteOff (castPtr p) offset x >> io+    JLong    x -> pokeByteOff (castPtr p) offset x >> io+    JFloat   x -> pokeByteOff (castPtr p) offset x >> io+    JDouble  x -> pokeByteOff (castPtr p) offset x >> io++    JObject (J x) -> withForeignPtr x $ \xp ->+      pokeByteOff (castPtr p) offset xp >> io+  where+    offset = n * sizeOfJValue++-- | Get the Java type of a value.+jtypeOf :: JValue -> SomeSing JType+jtypeOf (JBoolean _) = SomeSing (sing :: Sing ('Prim "boolean"))+jtypeOf (JByte _) = SomeSing (sing :: Sing ('Prim "byte"))+jtypeOf (JChar _) = SomeSing (sing :: Sing ('Prim "char"))+jtypeOf (JShort _) = SomeSing (sing :: Sing ('Prim "short"))+jtypeOf (JInt _) = SomeSing (sing :: Sing ('Prim "int"))+jtypeOf (JLong _) = SomeSing (sing :: Sing ('Prim "long"))+jtypeOf (JFloat _) = SomeSing (sing :: Sing ('Prim "float"))+jtypeOf (JDouble _) = SomeSing (sing :: Sing ('Prim "double"))+jtypeOf (JObject (_ :: J ty)) = SomeSing (sing :: Sing ty)++-- | Create a null-terminated string.+build :: Builder -> JNI.String+build =+  JNI.unsafeFromByteString .+  BSL.toStrict .+  Builder.toLazyByteString .+  (<> Builder.char7 '\NUL')++-- | The name of a type, suitable for passing to 'Foreign.JNI.findClass'.+referenceTypeName :: IsReferenceType ty => Sing (ty :: JType) -> ReferenceTypeName+referenceTypeName (SClass sym) = ReferenceTypeName $ build $ classSymbolBuilder sym+referenceTypeName (SIface sym) = ReferenceTypeName $ build $ classSymbolBuilder sym+referenceTypeName ty@(SArray _) = ReferenceTypeName $ build $ signatureBuilder ty+referenceTypeName (SGeneric ty@(SClass _) _) = referenceTypeName ty+referenceTypeName (SGeneric ty@(SIface _) _) = referenceTypeName ty+referenceTypeName _ = error "referenceTypeName: Impossible."++classSymbolBuilder :: String -> Builder+classSymbolBuilder sym =+    Prim.primMapByteStringFixed (subst Prim.>$< Prim.word8)+      (JNI.toByteString $ JNI.fromChars sym)+  where+    subst (chr . fromIntegral -> '.') = fromIntegral (ord '/')+    subst x = x++signatureBuilder :: Sing (ty :: JType) -> Builder+signatureBuilder (SClass sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';'+signatureBuilder (SIface sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';'+signatureBuilder (SPrim "boolean") = Builder.char7 'Z'+signatureBuilder (SPrim "byte") = Builder.char7 'B'+signatureBuilder (SPrim "char") = Builder.char7 'C'+signatureBuilder (SPrim "short") = Builder.char7 'S'+signatureBuilder (SPrim "int") = Builder.char7 'I'+signatureBuilder (SPrim "long") = Builder.char7 'J'+signatureBuilder (SPrim "float") = Builder.char7 'F'+signatureBuilder (SPrim "double") = Builder.char7 'D'+signatureBuilder (SPrim sym) = error $ "Unknown primitive: " ++ sym+signatureBuilder (SArray ty) = Builder.char7 '[' <> signatureBuilder ty+signatureBuilder (SGeneric ty _) = signatureBuilder ty+signatureBuilder SVoid = Builder.char7 'V'++-- | Construct a JNI type signature from a Java type.+signature :: Sing (ty :: JType) -> Signature+signature = Signature . build . signatureBuilder++-- | Construct a method's JNI type signature, given the type of the arguments+-- and the return type.+methodSignature+  :: [SomeSing JType]+  -> Sing (ty :: JType)+  -> MethodSignature+methodSignature args ret =+    MethodSignature $+    build $+    Builder.char7 '(' <>+    mconcat (map (\(SomeSing s) -> signatureBuilder s) args) <>+    Builder.char7 ')' <>+    signatureBuilder ret++-- | Turn the raw pointer into an object.+objectFromPtr :: Ptr (J a) -> IO (J a)+objectFromPtr ptr = J <$> newForeignPtr_ ptr++-- | Get a raw pointer to an object. This is unsafe because if the argument is+-- the last usage occurrence of the given foreign pointer, then its finalizer(s)+-- will be run, which potentially invalidates the plain pointer just obtained.+unsafeObjectToPtr :: J a -> Ptr (J a)+unsafeObjectToPtr (J fptr) = unsafeForeignPtrToPtr fptr++type JObject = J ('Class "java.lang.Object")+type JClass = J ('Class "java.lang.Class")+type JString = J ('Class "java.lang.String")+type JThrowable = J ('Class "java.lang.Throwable")+type JArray a = J ('Array a)+type JObjectArray = JArray ('Class "java.lang.Object")+type JBooleanArray = JArray ('Prim "boolean")+type JByteArray = JArray ('Prim "byte")+type JCharArray = JArray ('Prim "char")+type JShortArray = JArray ('Prim "short")+type JIntArray = JArray ('Prim "int")+type JLongArray = JArray ('Prim "long")+type JFloatArray = JArray ('Prim "float")+type JDoubleArray = JArray ('Prim "double")+type JByteBuffer = J ('Class "java.nio.ByteBuffer")++jniCtx :: Context+jniCtx = mempty { ctxTypesTable = Map.fromList tytab } <> fptrCtx+  where+    tytab =+      [ -- Primitive types+        (TypeName "jboolean", [t| Word8 |])+      , (TypeName "jbyte", [t| CChar |])+      , (TypeName "jchar", [t| Word16 |])+      , (TypeName "jshort", [t| Int16 |])+      , (TypeName "jint", [t| Int32 |])+      , (TypeName "jlong", [t| Int64 |])+      , (TypeName "jfloat", [t| Float |])+      , (TypeName "jdouble", [t| Double |])+      -- Reference types+      , (TypeName "jobject", [t| Ptr JObject |])+      , (TypeName "jclass", [t| Ptr JClass |])+      , (TypeName "jstring", [t| Ptr JString |])+      , (TypeName "jarray", [t| Ptr JObject |])+      , (TypeName "jobjectArray", [t| Ptr JObjectArray |])+      , (TypeName "jbooleanArray", [t| Ptr JBooleanArray |])+      , (TypeName "jbyteArray", [t| Ptr JByteArray |])+      , (TypeName "jcharArray", [t| Ptr JCharArray |])+      , (TypeName "jshortArray", [t| Ptr JShortArray |])+      , (TypeName "jintArray", [t| Ptr JIntArray |])+      , (TypeName "jlongArray", [t| Ptr JLongArray |])+      , (TypeName "jfloatArray", [t| Ptr JFloatArray |])+      , (TypeName "jdoubleArray", [t| Ptr JDoubleArray |])+      , (TypeName "jthrowable", [t| Ptr JThrowable |])+      -- Internal types+      , (TypeName "JavaVM", [t| JVM |])+      , (TypeName "JNIEnv", [t| JNIEnv |])+      , (TypeName "JNINativeMethod", [t| JNINativeMethod |])+      , (TypeName "jfieldID", [t| JFieldID |])+      , (TypeName "jmethodID", [t| JMethodID |])+      , (TypeName "jsize", [t| Int32 |])+      , (TypeName "jvalue", [t| JValue |])+      ]
+ src/common/Foreign/JNI/Unsafe.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Low-level bindings to the Java Native Interface (JNI).+--+-- Read the+-- <https://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/jniTOC.html JNI spec>+-- for authoritative documentation as to what each of the functions in+-- this module does. The names of the bindings in this module were chosen to+-- match the names of the functions in the JNI spec.+--+-- All bindings in this module access the JNI via a thread-local variable of+-- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the+-- JVM, it needs to be attached. See 'JNI.runInAttachedThread'.+--+-- The 'String' type in this module is the type of JNI strings. See+-- "Foreign.JNI.String".+--+-- The functions in this module are considered unsafe in opposition+-- to those in "Foreign.JNI.Safe", which ensure that local references are not+-- leaked.++-- Reexports definitions from "Foreign.JNI.Unsafe.Internal".+module Foreign.JNI.Unsafe+  ( module Foreign.JNI.Unsafe.Internal+  , NoSuchMethod(..)+  , getMethodID+  , getStaticMethodID+  ) where++import Control.Exception (Exception, bracket, catch, throwIO)+import Data.List (intersperse)+import Data.Singletons (sing)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Foreign.JNI.Types+import Foreign.JNI.Internal (MethodSignature(..), jniMethodToJavaSignature)+import qualified Foreign.JNI.String as JNI+import qualified Foreign.JNI.Unsafe.Internal as Internal+import Foreign.JNI.Unsafe.Internal hiding (getMethodID, getStaticMethodID)+import Foreign.JNI.Unsafe.Internal.Introspection+import System.IO.Unsafe (unsafePerformIO)++-- | Throws when a method can't be found+data NoSuchMethod = NoSuchMethod+  { noSuchMethodClassName :: Text+  , noSuchMethodName :: Text+  , noSuchMethodSignature :: Text+  , noSuchMethodOverloadings :: [Text]+  } deriving Exception++instance Show NoSuchMethod where+  show exn = Text.unpack $ Text.concat $+    case noSuchMethodOverloadings exn of+      [] ->+        [ "No method named ", noSuchMethodName exn+        , " was found in class ", noSuchMethodClassName exn+        , "\nWas there a mispelling?"+        ]+      sigs ->+        [ "Couldn't find method\n  "+        , showMethod (noSuchMethodName exn) (noSuchMethodSignature exn)+        , "\nin class ", noSuchMethodClassName exn+        , ".\nThe available method overloadings are:\n"+        , Text.unlines $ map ("  "<>) sigs+        ]+    where+      showMethod methodName sig =+        case jniMethodToJavaSignature sig of+          -- A Left value is a bug, but we provide the JNI signature+          -- which is still useful.+          Left _ -> methodName <> ": " <> sig+          Right (args, ret) -> Text.concat $+            ret : " " : methodName : "(" : intersperse "," args ++ [")"]++getMethodID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> MethodSignature -- ^ JNI signature+  -> IO JMethodID+getMethodID cls method sig = catch+  (Internal.getMethodID cls method sig)+  (handleJVMException cls method sig)++getStaticMethodID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> MethodSignature -- ^ JNI signature+  -> IO JMethodID+getStaticMethodID cls method sig = catch+  (Internal.getStaticMethodID cls method sig)+  (handleJVMException cls method sig)++-- | The "NoSuchMethodError" class.+kexception :: JClass+{-# NOINLINE kexception #-}+kexception = unsafePerformIO $ bracket+  (findClass $ referenceTypeName $ sing @('Class "java.lang.NoSuchMethodError"))+  deleteLocalRef+  newGlobalRef++-- | When the exception is an instance of java.lang.NoSuchMethodError,+-- throw a verbose exception suggesting possible corrections.+-- If it isn't, throw it as is.+handleJVMException+  :: JClass+  -> JNI.String+  -> MethodSignature+  -> JVMException+  -> IO a+handleJVMException cls method (MethodSignature sig) (JVMException e) =+  isInstanceOf (upcast e) kexception >>= \case+    True -> do+      noSuchMethodOverloadings <- getSignatures cls method+      noSuchMethodClassName <- getClassName cls+      throwIO $ NoSuchMethod+        { noSuchMethodClassName+        , noSuchMethodName = Text.decodeUtf8 (JNI.toByteString method)+        , noSuchMethodSignature = Text.decodeUtf8 (JNI.toByteString sig)+        , noSuchMethodOverloadings+        }+    False -> throwIO $ JVMException e
+ src/common/Foreign/JNI/Unsafe/Internal.hs view
@@ -0,0 +1,1062 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- XXX This file uses cpphs for preprocessing instead of the system's native+-- CPP, because the OS X has subtly different whitespace behaviour in the+-- presence of concatenation.++module Foreign.JNI.Unsafe.Internal+  ( -- * JNI functions+    -- ** VM management+    withJVM+  , newJVM+  , destroyJVM+    -- ** Class loading+  , defineClass+  , JNINativeMethod(..)+  , registerNatives+    -- ** String wrappers+  , ReferenceTypeName+  , MethodSignature+  , Signature+    -- ** Exceptions+  , JVMException(..)+  , throw+  , throwNew+    -- ** Query functions+  , findClass+  , getFieldID+  , getStaticFieldID+  , getMethodID+  , getStaticMethodID+  , getObjectClass+  , isInstanceOf+    -- ** Reference manipulation+  , newGlobalRef+  , deleteGlobalRef+  , newGlobalRefNonFinalized+  , deleteGlobalRefNonFinalized+  , newLocalRef+  , deleteLocalRef+  , pushLocalFrame+  , popLocalFrame+  , submitToFinalizerThread+    -- ** Field accessor functions+    -- *** Get fields+  , getObjectField+  , getBooleanField+  , getIntField+  , getLongField+  , getCharField+  , getShortField+  , getByteField+  , getDoubleField+  , getFloatField+    -- *** Get static fields+  , getStaticObjectField+  , getStaticBooleanField+  , getStaticIntField+  , getStaticLongField+  , getStaticCharField+  , getStaticShortField+  , getStaticByteField+  , getStaticDoubleField+  , getStaticFloatField+    -- *** Set fields+  , setObjectField+  , setBooleanField+  , setIntField+  , setLongField+  , setCharField+  , setShortField+  , setByteField+  , setDoubleField+  , setFloatField+    -- *** Set static fields+  , setStaticObjectField+  , setStaticBooleanField+  , setStaticIntField+  , setStaticLongField+  , setStaticCharField+  , setStaticShortField+  , setStaticByteField+  , setStaticDoubleField+  , setStaticFloatField+    -- ** Method invocation+  , callObjectMethod+  , callBooleanMethod+  , callIntMethod+  , callLongMethod+  , callCharMethod+  , callShortMethod+  , callByteMethod+  , callDoubleMethod+  , callFloatMethod+  , callVoidMethod+  , callStaticObjectMethod+  , callStaticVoidMethod+  , callStaticBooleanMethod+  , callStaticIntMethod+  , callStaticLongMethod+  , callStaticCharMethod+  , callStaticShortMethod+  , callStaticByteMethod+  , callStaticDoubleMethod+  , callStaticFloatMethod+    -- ** Object construction+  , newObject+  , newString+  , newObjectArray+  , newBooleanArray+  , newByteArray+  , newCharArray+  , newShortArray+  , newIntArray+  , newLongArray+  , newFloatArray+  , newDoubleArray+    -- ** Array manipulation+  , getArrayLength+  , getStringLength+  , ArrayCopyFailed(..)+  , NullPointerException(..)+  , getBooleanArrayElements+  , getByteArrayElements+  , getCharArrayElements+  , getShortArrayElements+  , getIntArrayElements+  , getLongArrayElements+  , getFloatArrayElements+  , getDoubleArrayElements+  , getStringChars+  , getBooleanArrayRegion+  , getByteArrayRegion+  , getCharArrayRegion+  , getShortArrayRegion+  , getIntArrayRegion+  , getLongArrayRegion+  , getFloatArrayRegion+  , getDoubleArrayRegion+  , setBooleanArrayRegion+  , setByteArrayRegion+  , setCharArrayRegion+  , setShortArrayRegion+  , setIntArrayRegion+  , setLongArrayRegion+  , setFloatArrayRegion+  , setDoubleArrayRegion+  , releaseBooleanArrayElements+  , releaseByteArrayElements+  , releaseCharArrayElements+  , releaseShortArrayElements+  , releaseIntArrayElements+  , releaseLongArrayElements+  , releaseFloatArrayElements+  , releaseDoubleArrayElements+  , releaseStringChars+  , getObjectArrayElement+  , setObjectArrayElement+    -- * Thread management+  , attachCurrentThreadAsDaemon+  , detachCurrentThread+  , isCurrentThreadAttached+  , runInAttachedThread+  , ThreadNotAttached(..)+    -- * NIO support+  , DirectBufferFailed(..)+  , newDirectByteBuffer+  , getDirectBufferAddress+  , getDirectBufferCapacity+  ) where++import Control.Concurrent+  (isCurrentThreadBound, rtsSupportsBoundThreads, runInBoundThread)+import Control.Exception+  (Exception, SomeException, bracket, bracket_, catch, finally, handle, throwIO)+import Control.Monad (unless, void, when)+import Data.Choice+import Data.Coerce+import Data.Int+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Word+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Foreign.C (CChar)+import Foreign.ForeignPtr+  ( finalizeForeignPtr+  , newForeignPtr_+  , withForeignPtr+  )+import Foreign.JNI.Internal+import Foreign.JNI.Internal.RWLock (RWLock)+import qualified Foreign.JNI.Internal.RWLock as RWLock+import Foreign.JNI.Internal.BackgroundWorker (BackgroundWorker)+import qualified Foreign.JNI.Internal.BackgroundWorker as BackgroundWorker+import Foreign.JNI.NativeMethod+import Foreign.JNI.Types+import qualified Foreign.JNI.String as JNI+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (peek)+import GHC.ForeignPtr (newConcForeignPtr)+import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc)+import qualified Language.C.Inline as C+import qualified Language.C.Inline.Unsafe as CU+import qualified System.Exit+import System.IO (fixIO)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (String)+import qualified Prelude++C.context (C.baseCtx <> C.bsCtx <> jniCtx)++C.include "<jni.h>"+C.include "<stdio.h>"+C.include "<errno.h>"+C.include "<stdlib.h>"++-- A thread-local variable to cache the JNI environment. Accessing this variable+-- is faster than calling @jvm->GetEnv()@.+$(C.verbatim "static __thread JNIEnv* jniEnv; ")++-- | A JNI call may cause a (Java) exception to be raised. This module raises it+-- as a Haskell exception wrapping the Java exception.+newtype JVMException = JVMException JThrowable++instance Exception JVMException++instance Show JVMException where+  show (JVMException e) = show e ++ ": Call (Foreign.JNI.showException e) to see details."++-- | Thrown when @Get<PrimitiveType>ArrayElements@ returns a null pointer,+-- because it wanted to copy the array contents but couldn't. In this case the+-- JVM doesn't throw OutOfMemory according to the JNI spec.+data ArrayCopyFailed = ArrayCopyFailed+  deriving (Exception, Show)++-- Thrown when @NewDirectByteBuffer@ or @GetDirectBufferAddress@ returns NULL,+-- and when @GetDirectBufferCapacity@ return @-1@.+data DirectBufferFailed = DirectBufferFailed+  deriving (Exception, Show)++-- | A null reference is found where a non-null reference was expected.+data NullPointerException = NullPointerException+  deriving (Exception, Show)++-- | A JNI call is made from a thread not attached to the JVM.+data ThreadNotAttached = ThreadNotAttached+  deriving (Exception, Show)++-- | A JNI call is made from an unbound thread.+data ThreadNotBound = ThreadNotBound+  deriving (Exception, Show)++-- | Thrown when an JNI call is made from an unbound thread.+data JNIError = JNIError Prelude.String Int32+  deriving Show++instance Exception JNIError++-- | Map Java exceptions to Haskell exceptions.+throwIfException :: Ptr JNIEnv -> IO a -> IO a+throwIfException env m = m `finally` do+    excptr <- [CU.exp| jthrowable { (*$(JNIEnv *env))->ExceptionOccurred($(JNIEnv *env)) } |]+    unless (excptr == nullPtr) $ do+      [CU.exp| void { (*$(JNIEnv *env))->ExceptionClear($(JNIEnv *env)) } |]+      throwIO . JVMException =<< newGlobalRef =<< objectFromPtr excptr++-- | Check whether a pointer is null.+throwIfNull :: Exception e => e -> IO (Ptr a) -> IO (Ptr a)+throwIfNull e m = do+    ptr <- m+    if ptr == nullPtr+    then throwIO e+    else return ptr++-- | Throws an error if the given reference is null, otherwise performs+-- the given io action.+throwIfJNull :: J ty -> IO a -> IO a+throwIfJNull j io =+    if j == jnull+    then throwIO NullPointerException+    else io++-- | This lock is used to avoid the JVM from dying before any finalizers+-- deleting global references are finished.+--+-- Finalizers try to acquire read locks.+--+-- The JVM acquires a write lock before shutdown. Thence, finalizers fail to+-- acquire read locks and behave as noops.+globalJVMLock :: RWLock+globalJVMLock = unsafePerformIO RWLock.new+{-# NOINLINE globalJVMLock #-}++throwIfNotOK_ :: HasCallStack => IO Int32 -> IO ()+throwIfNotOK_ m = m >>= \case+  rc+    | rc == [CU.pure| jint { JNI_OK } |] -> return ()+    | rc == [CU.pure| jint { JNI_EDETACHED } |] -> throwIO ThreadNotAttached+    | otherwise -> throwIO $ JNIError (prettySrcLoc loc) rc+  where+    (_, loc):_ = getCallStack callStack++attachCurrentThreadAsDaemon :: IO ()+attachCurrentThreadAsDaemon = do+    checkBoundness+    throwIfNotOK_+      [CU.exp| jint {+        (*$(JavaVM* jvm))->AttachCurrentThreadAsDaemon($(JavaVM* jvm), (void**)&jniEnv, NULL)+      } |]++detachCurrentThread :: IO ()+detachCurrentThread =+    throwIfNotOK_+    [CU.block| jint {+      int rc = (*$(JavaVM* jvm))->DetachCurrentThread($(JavaVM* jvm));+      if (rc == JNI_OK)+        jniEnv = NULL;+      return rc;+    } |]++-- | Tells whether the calling thread is attached to the JVM.+isCurrentThreadAttached :: IO Bool+isCurrentThreadAttached =+    catch (getJNIEnv >> return True) (\ThreadNotAttached -> return False)++-- | Attaches the calling thread to the JVM, runs the given IO action and+-- then detaches the thread.+--+-- If the thread is already attached no attaching and detaching is performed.+runInAttachedThread :: IO a -> IO a+runInAttachedThread io = do+    attached <- isCurrentThreadAttached+    if attached+    then io+    else bracket_+          attachCurrentThreadAsDaemon+          detachCurrentThread+          io++-- | The current JVM+--+-- Assumes there's at most one JVM. The current JNI spec (2016) says only+-- one JVM per process is supported anyways.+{-# NOINLINE jvm #-}+jvm :: Ptr JVM+jvm = unsafePerformIO $ alloca $ \pjvm -> alloca $ \pnum_jvms -> do+    throwIfNotOK_+      [CU.exp| jint {+        JNI_GetCreatedJavaVMs($(JavaVM** pjvm), 1, $(jsize* pnum_jvms))+      }|]+    num_jvms <- peek pnum_jvms+    when (num_jvms == 0) $+      fail "JNI_GetCreatedJavaVMs: No JVM has been initialized yet."+    when (num_jvms > 1) $+      fail "JNI_GetCreatedJavaVMs: There are multiple JVMs but only one is supported."+    peek pjvm++-- | Yields the JNIEnv of the calling thread.+--+-- Yields @Nothing@ if the calling thread is not attached to the JVM.+getJNIEnv :: IO (Ptr JNIEnv)+getJNIEnv = [CU.exp| JNIEnv* { jniEnv } |] >>= \case+    env | env == nullPtr -> do+      throwIfNotOK_+        [CU.exp| jint {+          (*$(JavaVM* jvm))->GetEnv($(JavaVM* jvm), (void**)&jniEnv, JNI_VERSION_1_6)+        }|]+      [CU.exp| JNIEnv* { jniEnv } |]+    env -> return env++-- | Run an action against the appropriate 'JNIEnv'.+--+-- Each OS thread has its own 'JNIEnv', which this function gives access to.+withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a+withJNIEnv f = getJNIEnv >>= f++useAsCStrings :: [ByteString] -> ([Ptr CChar] -> IO a) -> IO a+useAsCStrings strs m =+  foldr (\str k cstrs -> BS.useAsCString str $ \cstr -> k (cstr:cstrs)) m strs []++-- | Create a new JVM, with the given arguments. /Can only be called once/. Best+-- practice: use 'withJVM' instead. Only useful for GHCi.+newJVM :: [ByteString] -> IO JVM+newJVM options = JVM_ <$> do+    checkBoundness+    startJVM options <* startFinalizerThread+  where+    startFinalizerThread =+      BackgroundWorker.create+          (exitOnError . runInBoundThread . runInAttachedThread)+      >>= writeIORef finalizerThread++    exitOnError = handle $ \(e :: SomeException) -> do+      System.Exit.die $ "Haskell jni package: error in finalizer thread: " ++ show e++    startJVM options =+      useAsCStrings options $ \cstrs -> do+        withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do+          let n = fromIntegral (length cstrs) :: C.CInt++          [C.block| JavaVM * {+            JavaVM *jvm;+            JavaVMInitArgs vm_args;+            JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n));+            for(int i = 0; i < $(int n); i++)+                options[i].optionString = $(char **coptions)[i];+            vm_args.version = JNI_VERSION_1_6;+            vm_args.nOptions = $(int n);+            vm_args.options = options;+            vm_args.ignoreUnrecognized = 0;+            JNI_CreateJavaVM(&jvm, (void**)&jniEnv, &vm_args);+            free(options);+            return jvm; } |]++checkBoundness :: IO ()+checkBoundness =+  if rtsSupportsBoundThreads then do+    bound <- isCurrentThreadBound+    unless bound (throwIO ThreadNotBound)+  else+    error $ unlines+      [ "jni won't work with a non-threaded runtime."+      , "Perhaps link your program with -threaded."+      ]++-- | Deallocate a 'JVM' created using 'newJVM'.+destroyJVM :: JVM -> IO ()+destroyJVM (JVM_ jvm) = do+    readIORef finalizerThread >>= BackgroundWorker.stop+    writeIORef finalizerThread uninitializedFinalizerThread+    RWLock.acquireWriteLock globalJVMLock+    [C.block| void {+        (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm));+        jniEnv = NULL;+    } |]++-- | Create a new JVM, with the given arguments. Destroy it once the given+-- action completes. /Can only be called once/. Best practice: use it to wrap+-- your @main@ function.+withJVM :: [ByteString] -> IO a -> IO a+withJVM options action = bracket (newJVM options) destroyJVM (const action)++defineClass+  :: Coercible o (J ('Class "java.lang.ClassLoader"))+  => ReferenceTypeName -- ^ Class name+  -> o -- ^ Loader+  -> ByteString -- ^ Bytecode buffer+  -> IO JClass+defineClass (coerce -> name) (coerce -> upcast -> loader) buf = withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString name $ \namep ->+    objectFromPtr =<<+    [CU.exp| jclass {+      (*$(JNIEnv *env))->DefineClass($(JNIEnv *env),+                                     $(char *namep),+                                     $fptr-ptr:(jobject loader),+                                     $bs-ptr:buf,+                                     $bs-len:buf) } |]+registerNatives+  :: JClass+  -> [JNINativeMethod]+  -> IO ()+registerNatives cls methods = withJNIEnv $ \env ->+    throwIfException env $+    withArray methods $ \cmethods -> do+      let numMethods = fromIntegral $ length methods+      _ <- [CU.exp| jint {+             (*$(JNIEnv *env))->RegisterNatives($(JNIEnv *env),+                                                $fptr-ptr:(jclass cls),+                                                $(JNINativeMethod *cmethods),+                                                $(int numMethods)) } |]+      return ()++throw :: Coercible o (J a) => o -> IO ()+throw (coerce -> upcast -> obj) = withJNIEnv $ \env -> void $ do+    [CU.exp| jint {+       (*$(JNIEnv *env))->Throw($(JNIEnv *env),+                                $fptr-ptr:(jobject obj)) } |]++throwNew :: JClass -> JNI.String -> IO ()+throwNew cls msg = throwIfJNull cls $ withJNIEnv $ \env ->+    JNI.withString msg $ \msgp -> void $ do+    [CU.exp| jint {+       (*$(JNIEnv *env))->ThrowNew($(JNIEnv *env),+                                   $fptr-ptr:(jclass cls),+                                   $(char *msgp)) } |]++findClass+  :: ReferenceTypeName -- ^ Class name+  -> IO JClass+findClass (coerce -> name) = withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString name $ \namep ->+    objectFromPtr =<<+    [CU.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $(char *namep)) } |]++newObject :: JClass -> MethodSignature -> [JValue] -> IO JObject+newObject cls (coerce -> sig) args = throwIfJNull cls $ withJNIEnv $ \env ->+    throwIfException env $+    withJValues args $ \cargs -> do+      constr <- getMethodID cls "<init>" sig+      objectFromPtr =<< [CU.exp| jobject {+        (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env),+                                      $fptr-ptr:(jclass cls),+                                      $(jmethodID constr),+                                      $(jvalue *cargs)) } |]++getFieldID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> Signature -- ^ JNI signature+  -> IO JFieldID+getFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $+    withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString fieldname $ \fieldnamep ->+    JNI.withString sig $ \sigp ->+    [CU.exp| jfieldID {+      (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env),+                                    $fptr-ptr:(jclass cls),+                                    $(char *fieldnamep),+                                    $(char *sigp)) } |]++getStaticFieldID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> Signature -- ^ JNI signature+  -> IO JFieldID+getStaticFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $+    withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString fieldname $ \fieldnamep ->+    JNI.withString sig $ \sigp ->+    [CU.exp| jfieldID {+      (*$(JNIEnv *env))->GetStaticFieldID($(JNIEnv *env),+                                          $fptr-ptr:(jclass cls),+                                          $(char *fieldnamep),+                                          $(char *sigp)) } |]++#define GET_FIELD(name, hs_rettype, c_rettype) \+get/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> IO hs_rettype; \+get/**/name/**/Field (coerce -> upcast -> obj) field = withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.exp| c_rettype { \+      (*$(JNIEnv *env))->Get/**/name/**/Field($(JNIEnv *env), \+                                              $fptr-ptr:(jobject obj), \+                                              $(jfieldID field)) } |]++getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject+getObjectField x y =+    let GET_FIELD(Object, (Ptr JObject), jobject)+    in objectFromPtr =<< getObjectField x y+GET_FIELD(Boolean, Word8, jboolean)+GET_FIELD(Byte, CChar, jbyte)+GET_FIELD(Char, Word16, jchar)+GET_FIELD(Short, Int16, jshort)+GET_FIELD(Int, Int32, jint)+GET_FIELD(Long, Int64, jlong)+GET_FIELD(Float, Float, jfloat)+GET_FIELD(Double, Double, jdouble)++#define GET_STATIC_FIELD(name, hs_rettype, c_rettype) \+getStatic/**/name/**/Field :: JClass -> JFieldID -> IO hs_rettype; \+getStatic/**/name/**/Field klass field = throwIfJNull klass $ \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.exp| c_rettype { \+      (*$(JNIEnv *env))->GetStatic/**/name/**/Field($(JNIEnv *env), \+                                                    $fptr-ptr:(jclass klass), \+                                                    $(jfieldID field)) } |]++getStaticObjectField :: JClass -> JFieldID -> IO JObject+getStaticObjectField x y =+    let GET_STATIC_FIELD(Object, (Ptr JObject), jobject)+    in objectFromPtr =<< getStaticObjectField x y+GET_STATIC_FIELD(Boolean, Word8, jboolean)+GET_STATIC_FIELD(Byte, CChar, jbyte)+GET_STATIC_FIELD(Char, Word16, jchar)+GET_STATIC_FIELD(Short, Int16, jshort)+GET_STATIC_FIELD(Int, Int32, jint)+GET_STATIC_FIELD(Long, Int64, jlong)+GET_STATIC_FIELD(Float, Float, jfloat)+GET_STATIC_FIELD(Double, Double, jdouble)++#define SET_FIELD(name, hs_fieldtype, c_fieldtype) \+set/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> hs_fieldtype -> IO (); \+set/**/name/**/Field (coerce -> upcast -> obj) field x = \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.block| void { \+      (*$(JNIEnv *env))->Set/**/name/**/Field($(JNIEnv *env), \+                                              $fptr-ptr:(jobject obj), \+                                              $(jfieldID field), \+                                              $(c_fieldtype x)); } |]++setObjectField :: Coercible o (J a) => o -> JFieldID -> JObject -> IO ()+setObjectField x y z =+    let SET_FIELD(Object, (Ptr JObject), jobject)+    in withForeignPtr (coerce z) (setObjectField x y)+SET_FIELD(Boolean, Word8, jboolean)+SET_FIELD(Byte, CChar, jbyte)+SET_FIELD(Char, Word16, jchar)+SET_FIELD(Short, Int16, jshort)+SET_FIELD(Int, Int32, jint)+SET_FIELD(Long, Int64, jlong)+SET_FIELD(Float, Float, jfloat)+SET_FIELD(Double, Double, jdouble)++#define SET_STATIC_FIELD(name, hs_fieldtype, c_fieldtype) \+setStatic/**/name/**/Field :: JClass -> JFieldID -> hs_fieldtype -> IO (); \+setStatic/**/name/**/Field klass field x = throwIfJNull klass $ \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.block| void { \+      (*$(JNIEnv *env))->SetStatic/**/name/**/Field($(JNIEnv *env), \+                                                    $fptr-ptr:(jclass klass), \+                                                    $(jfieldID field), \+                                                    $(c_fieldtype x)); } |]++setStaticObjectField :: JClass -> JFieldID -> JObject -> IO ()+setStaticObjectField x y z =+    let SET_STATIC_FIELD(Object, (Ptr JObject), jobject)+    in withForeignPtr (coerce z) (setStaticObjectField x y)+SET_STATIC_FIELD(Boolean, Word8, jboolean)+SET_STATIC_FIELD(Byte, CChar, jbyte)+SET_STATIC_FIELD(Char, Word16, jchar)+SET_STATIC_FIELD(Short, Int16, jshort)+SET_STATIC_FIELD(Int, Int32, jint)+SET_STATIC_FIELD(Long, Int64, jlong)+SET_STATIC_FIELD(Float, Float, jfloat)+SET_STATIC_FIELD(Double, Double, jdouble)++getMethodID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> MethodSignature -- ^ JNI signature+  -> IO JMethodID+getMethodID cls methodname (coerce -> sig) = throwIfJNull cls $+    withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString methodname $ \methodnamep ->+    JNI.withString sig $ \sigp ->+    [CU.exp| jmethodID {+      (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env),+                                     $fptr-ptr:(jclass cls),+                                     $(char *methodnamep),+                                     $(char *sigp)) } |]++getStaticMethodID+  :: JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  -> MethodSignature -- ^ JNI signature+  -> IO JMethodID+getStaticMethodID cls methodname (coerce -> sig) = throwIfJNull cls $+    withJNIEnv $ \env ->+    throwIfException env $+    JNI.withString methodname $ \methodnamep ->+    JNI.withString sig $ \sigp ->+    [CU.exp| jmethodID {+      (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env),+                                           $fptr-ptr:(jclass cls),+                                           $(char *methodnamep),+                                           $(char *sigp)) } |]++getObjectClass :: Coercible o (J ty) => o -> IO JClass+getObjectClass (coerce -> upcast -> obj) = throwIfJNull obj $+    withJNIEnv $ \env ->+    objectFromPtr =<<+    [CU.exp| jclass {+      (*$(JNIEnv *env))->GetObjectClass($(JNIEnv *env),+                                        $fptr-ptr:(jobject obj)) } |]++-- | Creates a global reference to the object referred to by+-- the given reference.+--+-- Arranges for a finalizer to call 'deleteGlobalRef' when the+-- global reference is no longer reachable on the Haskell side.+newGlobalRef :: Coercible o (J ty) => o -> IO o+newGlobalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> do+    gobj <-+      [CU.exp| jobject {+        (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env),+                                        $fptr-ptr:(jobject obj)) } |]+    fixIO $ \j ->+      coerce <$> J <$>+        newConcForeignPtr gobj+          (submitToFinalizerThread $ deleteGlobalRefNonFinalized j)++deleteGlobalRef :: Coercible o (J ty) => o -> IO ()+deleteGlobalRef (coerce -> J p) = finalizeForeignPtr p++-- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy+-- the reference when it is not longer reachable. Use+-- 'deleteGlobalRefNonFinalized' to destroy this reference.+newGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO o+newGlobalRefNonFinalized (coerce -> upcast -> obj) = withJNIEnv $ \env -> do+    gobj <-+      [CU.exp| jobject {+        (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env),+                                        $fptr-ptr:(jobject obj)) } |]+    coerce <$> J <$> newForeignPtr_ gobj++-- | Like 'deleteGlobalRef' but it can be used only on references created with+-- 'newGlobalRefNonFinalized'.+deleteGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO ()+deleteGlobalRefNonFinalized (coerce -> upcast -> obj) = do+    bracket (RWLock.tryAcquireReadLock globalJVMLock)+            (\doRead -> when (toBool doRead) $ RWLock.releaseReadLock globalJVMLock)+            $ \doRead ->+      when (toBool doRead) $ withJNIEnv $ \env -> do+        [CU.block| void { (*$(JNIEnv *env))->DeleteGlobalRef($(JNIEnv *env)+                                                            ,$fptr-ptr:(jobject obj));+                        } |]++-- NB: Cannot add a finalizer to local references because it may+-- run in a thread where the reference is not valid.+newLocalRef :: Coercible o (J ty) => o -> IO o+newLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env ->+    coerce <$> (objectFromPtr =<<)+    [CU.exp| jobject {+      (*$(JNIEnv *env))->NewLocalRef($(JNIEnv *env),+                                     $fptr-ptr:(jobject obj)) } |]++deleteLocalRef :: Coercible o (J ty) => o -> IO ()+deleteLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env ->+    [CU.exp| void {+      (*$(JNIEnv *env))->DeleteLocalRef($(JNIEnv *env),+                                        $fptr-ptr:(jobject obj)) } |]++pushLocalFrame :: Int32 -> IO ()+pushLocalFrame (coerce -> capacity) = withJNIEnv $ \env ->+    -- We ignore the output as it is always 0 on success and throws an+    -- exception otherwise.+    throwIfException env $ void $+    [CU.block| jint {+      (*$(JNIEnv *env))->PushLocalFrame($(JNIEnv *env),+                                        $(jint capacity)); } |]++popLocalFrame :: Coercible o (J ty) => o -> IO o+popLocalFrame (coerce -> upcast -> obj) = withJNIEnv $ \env ->+    coerce <$> (objectFromPtr =<<)+    [CU.exp| jobject {+      (*$(JNIEnv *env))->PopLocalFrame($(JNIEnv *env),+                                       $fptr-ptr:(jobject obj)) } |]++-- Modern CPP does have ## for concatenating strings, but we use the hacky /**/+-- comment syntax for string concatenation. This is because GHC passes+-- the -traditional flag to the preprocessor by default, which turns off several+-- modern CPP features.++#define CALL_METHOD(name, hs_rettype, c_rettype) \+call/**/name/**/Method :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO hs_rettype; \+call/**/name/**/Method (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> \+    throwIfException env $ \+    withJValues args $ \cargs -> \+    [C.exp| c_rettype { \+      (*$(JNIEnv *env))->Call/**/name/**/MethodA($(JNIEnv *env), \+                                                 $fptr-ptr:(jobject obj), \+                                                 $(jmethodID method), \+                                                 $(jvalue *cargs)) } |]++CALL_METHOD(Void, (), void)+callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject+callObjectMethod x y z =+    let CALL_METHOD(Object, (Ptr JObject), jobject)+    in objectFromPtr =<< callObjectMethod x y z+callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool+callBooleanMethod x y z =+    let CALL_METHOD(Boolean, Word8, jboolean)+    in toEnum . fromIntegral <$> callBooleanMethod x y z+CALL_METHOD(Byte, CChar, jbyte)+CALL_METHOD(Char, Word16, jchar)+CALL_METHOD(Short, Int16, jshort)+CALL_METHOD(Int, Int32, jint)+CALL_METHOD(Long, Int64, jlong)+CALL_METHOD(Float, Float, jfloat)+CALL_METHOD(Double, Double, jdouble)++#define CALL_STATIC_METHOD(name, hs_rettype, c_rettype) \+callStatic/**/name/**/Method :: JClass -> JMethodID -> [JValue] -> IO hs_rettype; \+callStatic/**/name/**/Method cls method args = throwIfJNull cls $ \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    withJValues args $ \cargs -> \+    [C.exp| c_rettype { \+      (*$(JNIEnv *env))->CallStatic/**/name/**/MethodA($(JNIEnv *env), \+                                                       $fptr-ptr:(jclass cls), \+                                                       $(jmethodID method), \+                                                       $(jvalue *cargs)) } |]++CALL_STATIC_METHOD(Void, (), void)+callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject+callStaticObjectMethod x y z =+    let CALL_STATIC_METHOD(Object, (Ptr JObject), jobject)+    in objectFromPtr =<< callStaticObjectMethod x y z+callStaticBooleanMethod :: JClass -> JMethodID -> [JValue] -> IO Bool+callStaticBooleanMethod x y z =+    let CALL_STATIC_METHOD(Boolean, Word8, jboolean)+    in toEnum . fromIntegral <$> callStaticBooleanMethod x y z+CALL_STATIC_METHOD(Byte, CChar, jbyte)+CALL_STATIC_METHOD(Char, Word16, jchar)+CALL_STATIC_METHOD(Short, Int16, jshort)+CALL_STATIC_METHOD(Int, Int32, jint)+CALL_STATIC_METHOD(Long, Int64, jlong)+CALL_STATIC_METHOD(Float, Float, jfloat)+CALL_STATIC_METHOD(Double, Double, jdouble)++newObjectArray :: Int32 -> JClass -> IO JObjectArray+newObjectArray sz cls = throwIfJNull cls $ withJNIEnv $ \env ->+    throwIfException env $+    objectFromPtr =<<+    [CU.exp| jobjectArray {+      (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env),+                                        $(jsize sz),+                                        $fptr-ptr:(jclass cls),+                                        NULL) } |]++#define NEW_ARRAY(name, c_rettype) \+new/**/name/**/Array :: Int32 -> IO J/**/name/**/Array; \+new/**/name/**/Array sz = withJNIEnv $ \env -> \+    throwIfException env $ \+    objectFromPtr =<< \+    [CU.exp| c_rettype/**/Array { \+      (*$(JNIEnv *env))->New/**/name/**/Array($(JNIEnv *env), \+                                              $(jsize sz)) } |]++NEW_ARRAY(Boolean, jboolean)+NEW_ARRAY(Byte, jbyte)+NEW_ARRAY(Char, jchar)+NEW_ARRAY(Short, jshort)+NEW_ARRAY(Int, jint)+NEW_ARRAY(Long, jlong)+NEW_ARRAY(Float, jfloat)+NEW_ARRAY(Double, jdouble)++newString :: Ptr Word16 -> Int32 -> IO JString+newString ptr len = withJNIEnv $ \env ->+    throwIfException env $+    objectFromPtr =<<+    [CU.exp| jstring {+      (*$(JNIEnv *env))->NewString($(JNIEnv *env),+                                   $(jchar *ptr),+                                   $(jsize len)) } |]++getArrayLength :: Coercible o (JArray a) => o -> IO Int32+getArrayLength (coerce -> upcast -> array) = throwIfJNull array $+    withJNIEnv $ \env ->+    [C.exp| jsize {+      (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env),+                                        $fptr-ptr:(jarray array)) } |]++getStringLength :: JString -> IO Int32+getStringLength jstr = throwIfJNull jstr $ withJNIEnv $ \env ->+    [CU.exp| jsize {+      (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env),+                                         $fptr-ptr:(jstring jstr)) } |]++#define GET_ARRAY_ELEMENTS(name, hs_rettype, c_rettype) \+get/**/name/**/ArrayElements :: J/**/name/**/Array -> IO (Ptr hs_rettype); \+get/**/name/**/ArrayElements (upcast -> array) = throwIfJNull array $ \+    withJNIEnv $ \env -> \+    throwIfNull ArrayCopyFailed $ \+    [CU.exp| c_rettype* { \+      (*$(JNIEnv *env))->Get/**/name/**/ArrayElements($(JNIEnv *env), \+                                                      $fptr-ptr:(jobject array), \+                                                      NULL) } |]++GET_ARRAY_ELEMENTS(Boolean, Word8, jboolean)+GET_ARRAY_ELEMENTS(Byte, CChar, jbyte)+GET_ARRAY_ELEMENTS(Char, Word16, jchar)+GET_ARRAY_ELEMENTS(Short, Int16, jshort)+GET_ARRAY_ELEMENTS(Int, Int32, jint)+GET_ARRAY_ELEMENTS(Long, Int64, jlong)+GET_ARRAY_ELEMENTS(Float, Float, jfloat)+GET_ARRAY_ELEMENTS(Double, Double, jdouble)++getStringChars :: JString -> IO (Ptr Word16)+getStringChars jstr = throwIfJNull jstr $ withJNIEnv $ \env ->+    throwIfNull ArrayCopyFailed $+    [CU.exp| const jchar* {+      (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env),+                                        $fptr-ptr:(jstring jstr),+                                        NULL) } |]++#define GET_ARRAY_REGION(name, hs_argtype, c_argtype) \+get/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \+get/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.exp| void { \+      (*$(JNIEnv *env))->Get/**/name/**/ArrayRegion($(JNIEnv *env), \+                                                    $fptr-ptr:(c_argtype/**/Array array), \+                                                    $(jsize start), \+                                                    $(jsize len), \+                                                    $(c_argtype *buf)) } |]++GET_ARRAY_REGION(Boolean, Word8, jboolean)+GET_ARRAY_REGION(Byte, CChar, jbyte)+GET_ARRAY_REGION(Char, Word16, jchar)+GET_ARRAY_REGION(Short, Int16, jshort)+GET_ARRAY_REGION(Int, Int32, jint)+GET_ARRAY_REGION(Long, Int64, jlong)+GET_ARRAY_REGION(Float, Float, jfloat)+GET_ARRAY_REGION(Double, Double, jdouble)++#define SET_ARRAY_REGION(name, hs_argtype, c_argtype) \+set/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \+set/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \+    withJNIEnv $ \env -> \+    throwIfException env $ \+    [CU.exp| void { \+      (*$(JNIEnv *env))->Set/**/name/**/ArrayRegion($(JNIEnv *env), \+                                                    $fptr-ptr:(c_argtype/**/Array array), \+                                                    $(jsize start), \+                                                    $(jsize len), \+                                                    $(c_argtype *buf)) } |]++SET_ARRAY_REGION(Boolean, Word8, jboolean)+SET_ARRAY_REGION(Byte, CChar, jbyte)+SET_ARRAY_REGION(Char, Word16, jchar)+SET_ARRAY_REGION(Short, Int16, jshort)+SET_ARRAY_REGION(Int, Int32, jint)+SET_ARRAY_REGION(Long, Int64, jlong)+SET_ARRAY_REGION(Float, Float, jfloat)+SET_ARRAY_REGION(Double, Double, jdouble)++#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype, c_argtype) \+release/**/name/**/ArrayElements :: J/**/name/**/Array -> Ptr hs_argtype -> IO (); \+release/**/name/**/ArrayElements (upcast -> array) xs = throwIfJNull array $ \+    withJNIEnv $ \env -> \+    [CU.exp| void { \+      (*$(JNIEnv *env))->Release/**/name/**/ArrayElements($(JNIEnv *env), \+                                                          $fptr-ptr:(jobject array), \+                                                          $(c_argtype *xs), \+                                                          JNI_ABORT) } |]++RELEASE_ARRAY_ELEMENTS(Boolean, Word8, jboolean)+RELEASE_ARRAY_ELEMENTS(Byte, CChar, jbyte)+RELEASE_ARRAY_ELEMENTS(Char, Word16, jchar)+RELEASE_ARRAY_ELEMENTS(Short, Int16, jshort)+RELEASE_ARRAY_ELEMENTS(Int, Int32, jint)+RELEASE_ARRAY_ELEMENTS(Long, Int64, jlong)+RELEASE_ARRAY_ELEMENTS(Float, Float, jfloat)+RELEASE_ARRAY_ELEMENTS(Double, Double, jdouble)++releaseStringChars :: JString -> Ptr Word16 -> IO ()+releaseStringChars jstr chars = throwIfJNull jstr $ withJNIEnv $ \env ->+    [CU.exp| void {+      (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env),+                                            $fptr-ptr:(jstring jstr),+                                            $(jchar *chars)) } |]++getObjectArrayElement+  :: forall a o.+     (IsReferenceType a, Coercible o (J a))+  => JArray a+  -> Int32+  -> IO o+getObjectArrayElement (arrayUpcast -> array) i = throwIfJNull array $+    withJNIEnv $ \env ->+    ( (coerce :: J a -> o)+    . (unsafeCast :: JObject -> J a)+    ) <$> (objectFromPtr =<<)+    [C.exp| jobject {+      (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env),+                                               $fptr-ptr:(jarray array),+                                               $(jsize i)) } |]++setObjectArrayElement+  :: forall a o.+     (IsReferenceType a, Coercible o (J a))+  => JArray a+  -> Int32+  -> o+  -> IO ()+setObjectArrayElement (arrayUpcast -> array)+                      i+                      ((coerce :: o -> J a) -> upcast -> x) =+    throwIfJNull array $+    withJNIEnv $ \env ->+    [C.exp| void {+      (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env),+                                               $fptr-ptr:(jobjectArray array),+                                               $(jsize i),+                                               $fptr-ptr:(jobject x)); } |]++newDirectByteBuffer :: Ptr CChar -> Int64 -> IO JByteBuffer+newDirectByteBuffer (castPtr -> address) capacity =+    (throwIfNull NullPointerException (return address) >>) $+    withJNIEnv $ \env ->+    fmap (unsafeCast :: JObject -> JByteBuffer) $+    (objectFromPtr =<<) $+    throwIfNull DirectBufferFailed $+    [C.exp| jobject {+      (*$(JNIEnv *env))->NewDirectByteBuffer($(JNIEnv *env),+                                             $(void *address),+                                             $(jlong capacity)) } |]++getDirectBufferAddress :: JByteBuffer -> IO (Ptr CChar)+getDirectBufferAddress (upcast -> jbuffer) =+    throwIfJNull jbuffer $+    withJNIEnv $ \env ->+    fmap castPtr $+    throwIfNull DirectBufferFailed $+    [C.exp| void* {+      (*$(JNIEnv *env))->GetDirectBufferAddress($(JNIEnv *env),+                                                $fptr-ptr:(jobject jbuffer)) } |]++getDirectBufferCapacity :: JByteBuffer -> IO Int64+getDirectBufferCapacity (upcast -> jbuffer) = do+    capacity <- throwIfJNull jbuffer $+      withJNIEnv $ \env ->+      [C.exp| jlong {+        (*$(JNIEnv *env))->GetDirectBufferCapacity($(JNIEnv *env),+                                                   $fptr-ptr:(jobject jbuffer)) } |]+    if capacity >= 0 then+      return capacity+    else+      throwIO DirectBufferFailed++isInstanceOf :: Coercible o (J ty) => o -> JClass -> IO Bool+isInstanceOf (coerce -> upcast -> obj) cls = do+    w <- throwIfJNull obj $ throwIfJNull cls $+      withJNIEnv $ \env ->+      [C.exp| jboolean {+        (*$(JNIEnv *env))->IsInstanceOf($(JNIEnv *env),+                                        $fptr-ptr:(jobject obj),+                                        $fptr-ptr:(jclass cls)) } |]+    return $ toEnum $ fromIntegral w++-- | A background thread for cleaning global references+finalizerThread :: IORef BackgroundWorker+{-# NOINLINE finalizerThread #-}+finalizerThread = unsafePerformIO $ newIORef uninitializedFinalizerThread++uninitializedFinalizerThread :: BackgroundWorker+uninitializedFinalizerThread = error "The finalizer thread is not initialized"++-- | Runs a task in a long-living background thread attached to the+-- JVM. The thread is dedicated to release unused references to java+-- objects.+--+-- Useful to be called from GC finalizers, where attaching to the JVM would+-- be too expensive.+--+submitToFinalizerThread :: IO () -> IO ()+submitToFinalizerThread action = do+  worker <- readIORef finalizerThread+  BackgroundWorker.submitTask worker action
+ src/common/Foreign/JNI/Unsafe/Internal/Introspection.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Foreign.JNI.Unsafe.Internal.Introspection+ ( getClassName+ , getSignatures+ , toText+ , classGetNameMethod+ , showException+ ) where++import Control.Exception (bracket)+import Control.Monad (forM)+import Data.Coerce+import Data.Maybe (catMaybes)+import Data.Singletons+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Foreign as Text+import Foreign.JNI.Unsafe.Internal+import Foreign.JNI.Types+import qualified Foreign.JNI.String as JNI+import Prelude hiding (String)+import System.IO.Unsafe (unsafePerformIO)+import GHC.ForeignPtr (ForeignPtr)++-- | The "Class" class.+kclass :: JClass+{-# NOINLINE kclass #-}+kclass = unsafePerformIO $ bracket+  (findClass $ referenceTypeName $ sing @('Class "java.lang.Class"))+  deleteLocalRef+  newGlobalRef++-- | The "Method" class+kmethod :: JClass+{-# NOINLINE kmethod #-}+kmethod = unsafePerformIO $ bracket+  (findClass $ referenceTypeName $ sing @('Class "java.lang.reflect.Method"))+  deleteLocalRef+  newGlobalRef++-- | Class.getMethods+classGetMethodsMethod :: JMethodID+{-# NOINLINE classGetMethodsMethod #-}+classGetMethodsMethod = unsafePerformIO $+  getMethodID kclass (JNI.fromChars "getMethods") $+    methodSignature [] (SArray $ sing @('Class "java.lang.reflect.Method"))++-- | Method.toString+methodToStringMethod :: JMethodID+{-# NOINLINE methodToStringMethod #-}+methodToStringMethod = unsafePerformIO $+  getMethodID kmethod (JNI.fromChars "toString") $+    methodSignature [] (sing @('Class "java.lang.String"))++-- | Method.getName+methodGetNameMethod :: JMethodID+{-# NOINLINE methodGetNameMethod #-}+methodGetNameMethod = unsafePerformIO $+  getMethodID kmethod (JNI.fromChars "getName") $+    methodSignature [] (sing @('Class "java.lang.String"))++-- | Class.getName+classGetNameMethod :: JMethodID+{-# NOINLINE classGetNameMethod #-}+classGetNameMethod = unsafePerformIO $+  getMethodID kclass (JNI.fromChars "getName") $+    methodSignature [] (sing @('Class "java.lang.String"))++withDeleteLocalRef :: Coercible o (ForeignPtr (J ty)) => IO o -> (o -> IO c) -> IO c+withDeleteLocalRef grab action = bracket grab deleteLocalRef action++-- | @getSignatures c methodName@ yields the Java signatures of overloadings of+-- methods called @methodName@ in class @c@.+getSignatures :: JClass -> JNI.String -> IO [Text.Text]+getSignatures c methodName = withDeleteLocalRef+  (unsafeCast <$> callObjectMethod c classGetMethodsMethod []) $+  \(array :: JObjectArray) -> do+    l <- getArrayLength array+    let methodNameTxt = Text.decodeUtf8 $ JNI.toByteString methodName+    names <- forM [0 .. l - 1] $ \i -> withDeleteLocalRef+      (getObjectArrayElement array i) $+      \(ithObj :: JObject) -> withDeleteLocalRef+        (unsafeCast <$> callObjectMethod ithObj methodGetNameMethod []) $+        \(jName :: JString) -> do+          name <- toText jName+          if name == methodNameTxt+            then withDeleteLocalRef+              (unsafeCast <$> callObjectMethod ithObj methodToStringMethod []) $+              \(jMethodName :: JString) -> Just <$> toText jMethodName+            else return Nothing+    return $ catMaybes names++-- | Turns a JString into Text.+toText :: JString -> IO Text.Text+toText obj = bracket+  (getStringChars obj)+  (releaseStringChars obj) $+  \cs -> do+    sz <- fromIntegral <$> getStringLength obj+    txt <- Text.fromPtr cs sz+    return txt++-- | @getClassName c@ yields the name of class @c@+getClassName :: JClass -> IO Text.Text+getClassName c = withDeleteLocalRef+    (unsafeCast <$> callObjectMethod c classGetNameMethod []) $+    \(jName :: JString) -> toText jName++-- | The "Throwable" interface.+iThrowable :: JClass+{-# NOINLINE iThrowable #-}+iThrowable = unsafePerformIO $ withDeleteLocalRef+  (findClass $ referenceTypeName $ sing @('Class "java.lang.Throwable"))+  newGlobalRef++-- | Throwable.printStackTrace(PrintWriter s)+throwablePrintStackTraceMethod :: JMethodID+{-# NOINLINE throwablePrintStackTraceMethod #-}+throwablePrintStackTraceMethod = unsafePerformIO $+  getMethodID iThrowable (JNI.fromChars "printStackTrace") $+    methodSignature [SomeSing (sing :: Sing ('Class "java.io.PrintWriter"))] (sing :: Sing 'Void)++-- | The "StringWriter" class.+kStringWriter :: JClass+{-# NOINLINE kStringWriter #-}+kStringWriter = unsafePerformIO $ withDeleteLocalRef+  (findClass $ referenceTypeName $ sing @('Class "java.io.StringWriter"))+  newGlobalRef++-- | The "PrintWriter" class.+kPrintWriter :: JClass+{-# NOINLINE kPrintWriter #-}+kPrintWriter = unsafePerformIO $ withDeleteLocalRef+  (findClass $ referenceTypeName $ sing @('Class "java.io.PrintWriter"))+  newGlobalRef++-- | StringWriter.toString+stringWriterToStringMethod :: JMethodID+{-# NOINLINE stringWriterToStringMethod #-}+stringWriterToStringMethod = unsafePerformIO $+  getMethodID kStringWriter (JNI.fromChars "toString") $+    methodSignature [] (sing @('Class "java.lang.String"))++-- | Equivalent Java code:+-- StringWriter stringWriter = new StringWriter();+-- PrintWriter printWriter = new PrintWriter(stringWriter);+-- e.printStackTrace(printWriter);+-- return stringWriter.toString();+showException :: JVMException -> IO Text.Text+showException (JVMException e) = withDeleteLocalRef+  (newObject+    kStringWriter+    (methodSignature [] (sing :: Sing 'Void))+    [])+  $ \stringWriter -> withDeleteLocalRef+    (newObject+      kPrintWriter+      (methodSignature+        [SomeSing (sing :: Sing ('Class "java.io.Writer"))]+        (sing :: Sing 'Void))+      [JObject stringWriter])+    $ \printWriter -> do+      _ <- callVoidMethod+        e+        throwablePrintStackTraceMethod+        [JObject printWriter]+      withDeleteLocalRef+        (unsafeCast <$> callObjectMethod+          stringWriter+          stringWriterToStringMethod+          [])+        toText
+ src/linear-types/Data/Singletons.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Singletons where++import Data.Kind (Type)+import GHC.TypeLits (KnownSymbol)++type family Sing :: k -> Data.Kind.Type++class SingI ty  where+  sing :: Sing ty++instance SingI ('[] :: [k]) where+  sing = SNil+instance (SingI x, SingI xs) => SingI (x ': xs) where+  sing = SCons (sing @x) (sing @xs)++type instance Sing = SSymbol++data SSymbol n = KnownSymbol n => SSym++instance KnownSymbol n => SingI n where+  sing = SSym++type instance Sing = SList++data SList (xs :: [k]) where+  SNil :: SList '[]+  SCons :: Sing x -> SList xs -> SList (x ': xs)++data SomeSing k where+  SomeSing :: Sing (a :: k) -> SomeSing k++instance ShowSing k => Show (SList(a :: [k])) where+  showsPrec _ SNil = showString "SNil"+  showsPrec d sxs@(SCons ty tys) =+    case sxs of+      (_ :: SList (x : ys)) -> showParen (d > 10) $+        showString "SCons " . showsPrec 11 ty . showChar ' ' . showsPrec 11 tys+        :: (ShowSing' x, ShowSing' ys) => ShowS++class    (forall (z :: k). ShowSing' z) => ShowSing k+instance (forall (z :: k). ShowSing' z) => ShowSing k++class    Show (Sing z) => ShowSing' (z :: k)+instance Show (Sing z) => ShowSing' z
+ src/linear-types/Foreign/JNI/Safe.hs view
@@ -0,0 +1,505 @@+-- | Low-level bindings to the Java Native Interface (JNI).+--+-- This module provides a safer interface with linear types to the functions+-- of JNI. The compiler will check that all local references to java+-- objects are eventually deleted. Unlike garbage collection+-- and finalizers, the references are guaranteed to be removed when+-- execution reaches explicit API calls for that sake. See+-- <https://www.tweag.io/posts/2017-11-29-linear-jvm.html this blog post>+-- for the motivation.+--+-- Class references returned by 'findClass' and 'getObjectClass' are not+-- given linear multiplicity. The lifetime of classes is not so efemeral+-- and we expect them to be less prone to leak. For a similar reason,+-- global references aren't given linear multiplity either.+--+-- Read the+-- <https://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/jniTOC.html JNI spec>+-- for authoritative documentation as to what each of the functions in+-- this module does. The names of the bindings in this module were chosen to+-- match the names of the functions in the JNI spec.+--+-- All bindings in this module access the JNI via a thread-local variable of+-- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the+-- JVM, it needs to be attached. See 'JNI.runInAttachedThread'.+--+-- The 'String' type in this module is the type of JNI strings. See+-- "Foreign.JNI.String".+--+-- == Notes on linearity+--+-- Most functions taking references with linear multiplicty return the same+-- references so they can be used again. One notable exception is the+-- 'deleteLocalRef' function, which deletes a reference without returning it.+--+-- Another exception are the /call/ functions which take a list of 'JValue'+-- (`[JValue]`). /call/ functions delete all references with linear multiplicity+-- in the list of JValues. The references are not returned, so if the+-- caller wants to use them again, they need to be duplicated with+-- 'newLocalRef' before the call. Returning the `[JValue]`s would make it+-- rather clumsy to extract an object reference from it to use it again.+--+-- Because /call/ functions delete their reference arguments, they have+-- to discriminate references with linear multiplicity from the rest.+-- We introduce a new type 'Foreign.JNI.Types.Safe.J' of references with+-- linear multiplicity, and a type 'Foreign.JNI.Types.Safe.JValue' that+-- is a sum of primitive types, unrestricted references and references with+-- linear multiplicity.+--+-- Some functions like 'setObjectArrayElement' or 'setObjectField' offer+-- variants 'setObjectArrayElement_' and 'setObjectField_' which delete+-- one of the objects that the former functions would otherwise return.+--+-- Because we use linear multiplicities with local references only, we can+-- depend on local JNI frames to cleanup references when an exception occurs.+-- For this reason, functions or code blocks which use the JNI interface must+-- be wrapped with either 'withLocalFrame' or 'withLocalFrame_'.+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- XXX This file uses cpphs for preprocessing instead of the system's native+-- CPP, because the OS X has subtly different whitespace behaviour in the+-- presence of concatenation.++module Foreign.JNI.Safe+  ( module Foreign.JNI.Safe+  , JNI.withJVM+  ) where++import Control.Exception hiding (throw)+import Control.Monad+import Control.Monad.IO.Class.Linear (MonadIO(liftIO))+import qualified Control.Monad.Linear as Linear+import Data.Functor+import Data.Int+import Data.Word+import Foreign.C.Types+import qualified Foreign.JNI as JNI+import qualified Foreign.JNI.String as JNI+import qualified Foreign.JNI.Types as JNI+import Foreign.JNI.Types.Safe+import Foreign.Ptr (Ptr)+import qualified System.IO.Linear as Linear+import qualified Unsafe.Linear as Unsafe+import Prelude ((.))+import qualified Prelude+import Prelude.Linear hiding ((<*), (.))+++liftPreludeIO :: MonadIO m => Prelude.IO a -> m a+liftPreludeIO io = liftIO (Linear.fromSystemIO io)++liftPreludeIOU :: MonadIO m => Prelude.IO a -> m (Unrestricted a)+liftPreludeIOU io = liftIO (Linear.fromSystemIOU io)++throw :: MonadIO m => J a #-> m (J a)+throw = Unsafe.toLinear $ \x -> liftPreludeIO (x Prelude.<$ JNI.throw x)++throw_ :: MonadIO m => J a #-> m ()+throw_ x = throw x Linear.>>= deleteLocalRef++throwNew :: MonadIO m => JNI.JClass -> JNI.String #-> m ()+throwNew jclass = Unsafe.toLinear $ \msg ->+    liftPreludeIO (JNI.throwNew jclass msg)++findClass+  :: MonadIO m+  => ReferenceTypeName+  -> m (UnsafeUnrestrictedReference JNI.JClass)+findClass name = liftPreludeIO (UnsafeUnrestrictedReference <$> JNI.findClass name)++newObject+  :: MonadIO m+  => JNI.JClass+  -> MethodSignature+  #-> [JValue]+  #-> m JObject+newObject jclass = Unsafe.toLinear2 $ \m args ->+  liftPreludeIO (J <$> JNI.newObject jclass m (toJNIJValues args))++getFieldID+  :: MonadIO m+  => JNI.JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  #-> Signature -- ^ JNI signature+  #-> m (Unrestricted JFieldID)+getFieldID jclass = Unsafe.toLinear2 $ \fieldname sig ->+    liftPreludeIO (Unrestricted <$> JNI.getFieldID jclass fieldname sig)++getStaticFieldID+  :: MonadIO m+  => JNI.JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  #-> Signature -- ^ JNI signature+  #-> m (Unrestricted JFieldID)+getStaticFieldID jclass = Unsafe.toLinear2 $ \fieldname sig ->+    liftPreludeIO (Unrestricted <$> JNI.getStaticFieldID jclass fieldname sig)++#define GET_FIELD(name, hs_rettype) \+get/**/name/**/Field :: MonadIO m => J a #-> JFieldID #-> m (J a, Unrestricted hs_rettype); \+get/**/name/**/Field = Unsafe.toLinear2 $ \obj field -> \+    liftPreludeIO \+      ((,) obj . Unrestricted <$> JNI.get/**/name/**/Field (unJ obj) field)++getObjectField :: MonadIO m => J a #-> JFieldID #-> m (J a, JObject)+getObjectField = Unsafe.toLinear2 $ \obj field ->+    liftPreludeIO ((,) obj . J <$> JNI.getObjectField (unJ obj) field)++GET_FIELD(Boolean, Word8)+GET_FIELD(Byte, CChar)+GET_FIELD(Char, Word16)+GET_FIELD(Short, Int16)+GET_FIELD(Int, Int32)+GET_FIELD(Long, Int64)+GET_FIELD(Float, Float)+GET_FIELD(Double, Double)++#define GET_STATIC_FIELD(name, hs_rettype) \+getStatic/**/name/**/Field :: MonadIO m => JNI.JClass -> JFieldID #-> m (Unrestricted hs_rettype); \+getStatic/**/name/**/Field jclass = Unsafe.toLinear $ \field -> \+    liftPreludeIOU (JNI.getStatic/**/name/**/Field jclass field)++getStaticObjectField :: MonadIO m => JNI.JClass -> JFieldID #-> m JObject+getStaticObjectField jclass = Unsafe.toLinear $ \field ->+    liftPreludeIO (J <$> JNI.getStaticObjectField jclass field)++GET_STATIC_FIELD(Boolean, Word8)+GET_STATIC_FIELD(Byte, CChar)+GET_STATIC_FIELD(Char, Word16)+GET_STATIC_FIELD(Short, Int16)+GET_STATIC_FIELD(Int, Int32)+GET_STATIC_FIELD(Long, Int64)+GET_STATIC_FIELD(Float, Float)+GET_STATIC_FIELD(Double, Double)++#define SET_FIELD(name, hs_fieldtype) \+set/**/name/**/Field :: MonadIO m => J a #-> JFieldID #-> hs_fieldtype #-> m (J a); \+set/**/name/**/Field = Unsafe.toLinear2 $ \obj field -> Unsafe.toLinear $ \v -> \+    liftPreludeIO \+      (obj <$ JNI.set/**/name/**/Field (unJ obj) field v)++setObjectField+  :: MonadIO m+  => J a+  #-> JFieldID+  #-> JObject+  #-> m (J a, JObject)+setObjectField = Unsafe.toLinear3 $ \obj field v ->+    liftPreludeIO ((obj, v) <$ JNI.setObjectField (unJ obj) field (unJ v))++setObjectField_+  :: MonadIO m+  => J a+  #-> JFieldID+  #-> JObject+  #-> m (J a)+setObjectField_ _o f _v =+    setObjectField _o f _v Linear.>>= \(_o, _v) ->+      _o Linear.<$ deleteLocalRef _v++SET_FIELD(Boolean, Word8)+SET_FIELD(Byte, CChar)+SET_FIELD(Char, Word16)+SET_FIELD(Short, Int16)+SET_FIELD(Int, Int32)+SET_FIELD(Long, Int64)+SET_FIELD(Float, Float)+SET_FIELD(Double, Double)++#define SET_STATIC_FIELD(name, hs_fieldtype) \+setStatic/**/name/**/Field :: MonadIO m => JNI.JClass -> JFieldID #-> hs_fieldtype #-> m (); \+setStatic/**/name/**/Field jclass = Unsafe.toLinear2 $ \field v -> \+    liftPreludeIO (JNI.setStatic/**/name/**/Field jclass field v)++setStaticObjectField+  :: MonadIO m+  => JNI.JClass+  -> JFieldID+  #-> JObject+  #-> m JObject+setStaticObjectField jclass =+    Unsafe.toLinear2 $ \field v ->+      liftPreludeIO (v <$ JNI.setStaticObjectField jclass field (unJ v))++setStaticObjectField_+  :: MonadIO m+  => JNI.JClass+  -> JFieldID+  #-> JObject+  #-> m ()+setStaticObjectField_ c f _v =+    setStaticObjectField c f _v Linear.>>= deleteLocalRef++SET_STATIC_FIELD(Boolean, Word8)+SET_STATIC_FIELD(Byte, CChar)+SET_STATIC_FIELD(Char, Word16)+SET_STATIC_FIELD(Short, Int16)+SET_STATIC_FIELD(Int, Int32)+SET_STATIC_FIELD(Long, Int64)+SET_STATIC_FIELD(Float, Float)+SET_STATIC_FIELD(Double, Double)++getMethodID+  :: MonadIO m+  => JNI.JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  #-> MethodSignature -- ^ JNI signature+  #-> m (Unrestricted JMethodID)+getMethodID jclass = Unsafe.toLinear2 $ \methodname sig ->+  liftPreludeIO (Unrestricted <$> JNI.getMethodID jclass methodname sig)++getStaticMethodID+  :: MonadIO m+  => JNI.JClass -- ^ A class object as returned by 'findClass'+  -> JNI.String -- ^ Field name+  #-> MethodSignature -- ^ JNI signature+  #-> m (Unrestricted JMethodID)+getStaticMethodID jclass = Unsafe.toLinear2 $ \methodname sig ->+  liftPreludeIOU (JNI.getStaticMethodID jclass methodname sig)++getObjectClass+  :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference JNI.JClass)+getObjectClass = Unsafe.toLinear $ \o ->+    liftPreludeIO ((,) o . UnsafeUnrestrictedReference <$> JNI.getObjectClass (unJ o))++-- | Creates a global reference to the object referred to by+-- the given reference.+--+-- Arranges for a finalizer to call 'deleteGlobalRef' when the+-- global reference is no longer reachable on the Haskell side.+newGlobalRef+  :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference (JNI.J ty))+newGlobalRef = Unsafe.toLinear $ \o -> liftPreludeIO+    ((,) o . UnsafeUnrestrictedReference <$> JNI.newGlobalRef (unJ o))++-- | Like 'newGlobalRef' but it deletes the input instead of returning it.+newGlobalRef_+  :: MonadIO m => J ty #-> m (UnsafeUnrestrictedReference (JNI.J ty))+newGlobalRef_ j =+    newGlobalRef j Linear.>>= \(j1, g) -> g Linear.<$ deleteLocalRef j1++deleteGlobalRef :: MonadIO m => JNI.J ty -> m ()+deleteGlobalRef o = liftPreludeIO (JNI.deleteGlobalRef o)++-- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy+-- the reference when it is not longer reachable. Use+-- 'deleteGlobalRefNonFinalized' to destroy this reference.+newGlobalRefNonFinalized+  :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference (JNI.J ty))+newGlobalRefNonFinalized = Unsafe.toLinear $ \o ->+    liftPreludeIO ((,) o . UnsafeUnrestrictedReference <$>+             JNI.newGlobalRefNonFinalized (unJ o)+           )++-- | Like 'deleteGlobalRef' but it can be used only on references created with+-- 'newGlobalRefNonFinalized'.+deleteGlobalRefNonFinalized :: MonadIO m => J ty -> m ()+deleteGlobalRefNonFinalized o = liftPreludeIO (JNI.deleteGlobalRef o)++-- NB: Cannot add a finalizer to local references because it may+-- run in a thread where the reference is not valid.+newLocalRef :: MonadIO m => J ty #-> m (J ty, J ty)+newLocalRef = Unsafe.toLinear $ \o ->+    liftPreludeIO ((,) o . J <$> JNI.newLocalRef (unJ o))++deleteLocalRef :: MonadIO m => J ty #-> m ()+deleteLocalRef = Unsafe.toLinear $ \o ->+    liftPreludeIO (JNI.deleteLocalRef (unJ o))++-- | Runs the given computation in a local frame, which ensures that+-- if it throws an exception, all live local references created during+-- the computation will be deleted.+withLocalFrame :: Linear.IO (Unrestricted a) -> IO a+withLocalFrame = withLocalFrameWithSize 30++withLocalFrame_ :: Linear.IO () -> IO ()+withLocalFrame_ = withLocalFrameWithSize_ 30++withLocalFrameWithSize :: Int32 -> Linear.IO (Unrestricted a) -> IO a+withLocalFrameWithSize capacity linearIO = do+    bracket_+      (JNI.pushLocalFrame capacity)+      (JNI.popLocalFrame jnull)+      (Linear.withLinearIO linearIO)++withLocalFrameWithSize_ :: Int32 -> Linear.IO () -> IO ()+withLocalFrameWithSize_ capacity linearIO = do+    bracket_+      (JNI.pushLocalFrame capacity)+      (JNI.popLocalFrame jnull)+      (Linear.withLinearIO (linearIO Linear.>> Linear.return (Unrestricted ())))++#define CALL_METHOD(name, hs_rettype) \+call/**/name/**/Method :: MonadIO m => J a #-> JMethodID #-> [JValue] #-> m (J a, Unrestricted hs_rettype); \+call/**/name/**/Method = Unsafe.toLinear3 $ \obj method args -> \+    liftPreludeIO Prelude.$ \+      (,) obj . Unrestricted <$> JNI.call/**/name/**/Method (unJ obj) method (toJNIJValues args) \+       Prelude.<* deleteLinearJObjects args++deleteLinearJObjects :: [JValue] -> IO ()+deleteLinearJObjects = mapM_ Prelude.$ \case+    JObject j ->  (JNI.deleteLocalRef j)+    _ -> return ()++callVoidMethod :: MonadIO m => J a #-> JMethodID #-> [JValue] #-> m (J a)+callVoidMethod = Unsafe.toLinear3 $ \obj method args ->+    liftPreludeIO Prelude.$+      obj <$ JNI.callVoidMethod (unJ obj) method (toJNIJValues args)+        Prelude.<* deleteLinearJObjects args++callObjectMethod+  :: MonadIO m+  => J a+  #-> JMethodID+  #-> [JValue]+  #-> m (J a, JObject)+callObjectMethod = Unsafe.toLinear3 $ \obj method args ->+    liftPreludeIO Prelude.$+      (,) obj . J <$> JNI.callObjectMethod (unJ obj) method (toJNIJValues args)+        Prelude.<* deleteLinearJObjects args++CALL_METHOD(Boolean, Bool)+CALL_METHOD(Byte, CChar)+CALL_METHOD(Char, Word16)+CALL_METHOD(Short, Int16)+CALL_METHOD(Int, Int32)+CALL_METHOD(Long, Int64)+CALL_METHOD(Float, Float)+CALL_METHOD(Double, Double)++#define CALL_STATIC_METHOD(name, hs_rettype) \+callStatic/**/name/**/Method :: MonadIO m => JNI.JClass -> JMethodID #-> [JValue] #-> m (Unrestricted hs_rettype); \+callStatic/**/name/**/Method cls = Unsafe.toLinear2 $ \method args -> \+    liftPreludeIOU Prelude.$ \+      JNI.callStatic/**/name/**/Method cls method (toJNIJValues args) \+        Prelude.<* deleteLinearJObjects args++callStaticObjectMethod+  :: MonadIO m+  => JNI.JClass+  -> JMethodID+  #-> [JValue]+  #-> m JObject+callStaticObjectMethod jclass = Unsafe.toLinear2 $ \method args ->+    liftPreludeIO Prelude.$ do+      J <$> JNI.callStaticObjectMethod jclass method (toJNIJValues args)+        Prelude.<* deleteLinearJObjects args++CALL_STATIC_METHOD(Void, ())+CALL_STATIC_METHOD(Boolean, Bool)+CALL_STATIC_METHOD(Byte, CChar)+CALL_STATIC_METHOD(Char, Word16)+CALL_STATIC_METHOD(Short, Int16)+CALL_STATIC_METHOD(Int, Int32)+CALL_STATIC_METHOD(Long, Int64)+CALL_STATIC_METHOD(Float, Float)+CALL_STATIC_METHOD(Double, Double)++newObjectArray :: MonadIO m => Int32 -> JNI.JClass -> m JObjectArray+newObjectArray sz cls = liftPreludeIO (J <$> JNI.newObjectArray sz cls)++#define NEW_ARRAY(name) \+new/**/name/**/Array :: MonadIO m => Int32 -> m J/**/name/**/Array; \+new/**/name/**/Array sz = liftPreludeIO (J <$> JNI.new/**/name/**/Array sz)++NEW_ARRAY(Boolean)+NEW_ARRAY(Byte)+NEW_ARRAY(Char)+NEW_ARRAY(Short)+NEW_ARRAY(Int)+NEW_ARRAY(Long)+NEW_ARRAY(Float)+NEW_ARRAY(Double)++newString :: MonadIO m => Ptr Word16 -> Int32 -> m JString+newString ptr len = liftPreludeIO (J <$> JNI.newString ptr len)++getArrayLength :: MonadIO m => JArray a #-> m (JArray a, Unrestricted Int32)+getArrayLength = Unsafe.toLinear $ \o ->+    liftPreludeIO ((,) o . Unrestricted <$> JNI.getArrayLength (unJ o))++getStringLength :: MonadIO m => JString #-> m (JString, Int32)+getStringLength = Unsafe.toLinear $ \o ->+    liftPreludeIO ((,) o <$> JNI.getStringLength (unJ o))++#define GET_ARRAY_ELEMENTS(name, hs_rettype) \+get/**/name/**/ArrayElements :: MonadIO m => J/**/name/**/Array #-> m (J/**/name/**/Array, Unrestricted (Ptr hs_rettype)); \+get/**/name/**/ArrayElements = Unsafe.toLinear $ \a -> \+      liftPreludeIO Prelude.$ \+        (,) a . Unrestricted <$> \+          JNI.get/**/name/**/ArrayElements (unJ a)++GET_ARRAY_ELEMENTS(Boolean, Word8)+GET_ARRAY_ELEMENTS(Byte, CChar)+GET_ARRAY_ELEMENTS(Char, Word16)+GET_ARRAY_ELEMENTS(Short, Int16)+GET_ARRAY_ELEMENTS(Int, Int32)+GET_ARRAY_ELEMENTS(Long, Int64)+GET_ARRAY_ELEMENTS(Float, Float)+GET_ARRAY_ELEMENTS(Double, Double)++getStringChars :: MonadIO m => JString #-> m (JString, Ptr Word16)+getStringChars = Unsafe.toLinear $ \jstr ->+    liftPreludeIO ((,) jstr <$> JNI.getStringChars (unJ jstr))++#define SET_ARRAY_REGION(name, hs_argtype) \+set/**/name/**/ArrayRegion :: MonadIO m => J/**/name/**/Array #-> Int32 -> Int32 -> Ptr hs_argtype -> m J/**/name/**/Array; \+set/**/name/**/ArrayRegion = Unsafe.toLinear $ \array start len buf -> \+    liftPreludeIO (array <$ JNI.set/**/name/**/ArrayRegion (unJ array) start len buf)++SET_ARRAY_REGION(Boolean, Word8)+SET_ARRAY_REGION(Byte, CChar)+SET_ARRAY_REGION(Char, Word16)+SET_ARRAY_REGION(Short, Int16)+SET_ARRAY_REGION(Int, Int32)+SET_ARRAY_REGION(Long, Int64)+SET_ARRAY_REGION(Float, Float)+SET_ARRAY_REGION(Double, Double)++#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype) \+release/**/name/**/ArrayElements :: MonadIO m => J/**/name/**/Array #-> Ptr hs_argtype #-> m J/**/name/**/Array; \+release/**/name/**/ArrayElements = Unsafe.toLinear2 $ \array xs -> \+    liftPreludeIO (array <$ JNI.release/**/name/**/ArrayElements (unJ array) xs)++RELEASE_ARRAY_ELEMENTS(Boolean, Word8)+RELEASE_ARRAY_ELEMENTS(Byte, CChar)+RELEASE_ARRAY_ELEMENTS(Char, Word16)+RELEASE_ARRAY_ELEMENTS(Short, Int16)+RELEASE_ARRAY_ELEMENTS(Int, Int32)+RELEASE_ARRAY_ELEMENTS(Long, Int64)+RELEASE_ARRAY_ELEMENTS(Float, Float)+RELEASE_ARRAY_ELEMENTS(Double, Double)++releaseStringChars :: MonadIO m => JString #-> Ptr Word16 -> m JString+releaseStringChars = Unsafe.toLinear $ \jstr chars ->+    liftPreludeIO (jstr <$ JNI.releaseStringChars (unJ jstr) chars)++getObjectArrayElement+  :: (IsReferenceType a, MonadIO m)+  => JArray a+  #-> Int32+  #-> m (JArray a, J a)+getObjectArrayElement = Unsafe.toLinear2 $ \a i ->+    liftPreludeIO ((,) a . J <$> JNI.getObjectArrayElement (unJ a) i)++setObjectArrayElement+  :: (IsReferenceType a, MonadIO m)+  => JArray a+  #-> Int32+  -> J a+  #-> m (JArray a, J a)+setObjectArrayElement = Unsafe.toLinear $ \a i -> Unsafe.toLinear $ \o ->+    liftPreludeIO ((a, o) <$ JNI.setObjectArrayElement (unJ a) i (unJ o))++setObjectArrayElement_+  :: (IsReferenceType a, MonadIO m)+  => JArray a+  #-> Int32+  -> J a+  #-> m (JArray a)+setObjectArrayElement_ _a i _j =+    setObjectArrayElement _a i _j Linear.>>= \(_a, _j) ->+      _a Linear.<$ deleteLocalRef _j
+ src/linear-types/Foreign/JNI/Types/Safe.hs view
@@ -0,0 +1,108 @@+-- | Types used in the safe interface of JNI++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeOperators #-}++module Foreign.JNI.Types.Safe+  ( module Foreign.JNI.Types.Safe+  , JNI.IsReferenceType+  , JNI.IsPrimitiveType+  , JNI.JFieldID+  , JNI.JMethodID+  , JNI.JType(..)+  , type (JNI.<>)+  , JNI.JVM+  , JNI.MethodSignature+  , JNI.ReferenceTypeName+  , JNI.Signature+  , JNI.Sing+  , JNI.methodSignature+  , JNI.referenceTypeName+  ) where++import Data.Singletons+import Foreign.JNI.Types (type (<>), JType(..), IsReferenceType)+import qualified Foreign.JNI.Types as JNI+import qualified Unsafe.Linear as Unsafe++-- | A wrapper over J references+--+-- This wrapper is used to identify local references+-- which are tracked with linear types.+newtype J (a :: JType) = J { unJ :: JNI.J a }+  deriving (Eq, Show)++type role J representational++-- | The null reference.+jnull :: J a+jnull = J JNI.jnull++-- | Any object can be cast to @Object@.+upcast :: J a #-> JObject+upcast = Unsafe.toLinear (J . JNI.upcast . unJ)++-- | Any array of a reference type can be casted to an array of @Object@s.+arrayUpcast :: IsReferenceType ty => J ('Array ty) #-> JObjectArray+arrayUpcast = Unsafe.toLinear (J . JNI.arrayUpcast . unJ)++-- | Unsafe type cast. Should only be used to downcast.+unsafeCast :: J a #-> J b+unsafeCast = Unsafe.toLinear (J . JNI.unsafeCast . unJ)++-- | Parameterize the type of an object, making its type a /generic type/.+unsafeGeneric :: J a #-> J (a <> g)+unsafeGeneric = Unsafe.toLinear (J . JNI.generic . unJ)++-- | Get the base type of a generic type.+ungeneric :: J (a <> g) #-> J a+ungeneric = Unsafe.toLinear (J . JNI.unsafeUngeneric . unJ)++-- | A union type for uniformly passing arguments to methods.+data JValue+  = JValue JNI.JValue+  | forall a. SingI a => JObject {-# UNPACK #-} !(J a)++instance Show JValue where+  show (JValue jvalue) = "JValue (" ++ show jvalue ++ ")"+  show (JObject x) = "JObject " ++ show x++instance Eq JValue where+  (JValue x) == (JValue y) = x == y+  (JObject j0) == (JObject j1) = upcast j0 == upcast j1+  _ == _ = False++-- The array is valid only while evaluating @f@.+toJNIJValues :: [JValue] -> [JNI.JValue]+toJNIJValues = map $ \case+    JValue jvalue -> jvalue+    JObject (J j) -> JNI.JObject j++-- | A type to wrap unrestricted references+--+-- Unlike with linear references, the programmer is reponsible+-- for ensuring that the unrestricted references are destroyed+-- in timely fashion.+data UnsafeUnrestrictedReference a where+  UnsafeUnrestrictedReference :: a -> UnsafeUnrestrictedReference a++type JObject = J ('Class "java.lang.Object")+type JString = J ('Class "java.lang.String")+type JThrowable = J ('Class "java.lang.Throwable")+type JArray a = J ('Array a)+type JObjectArray = JArray ('Class "java.lang.Object")+type JBooleanArray = JArray ('Prim "boolean")+type JByteArray = JArray ('Prim "byte")+type JCharArray = JArray ('Prim "char")+type JShortArray = JArray ('Prim "short")+type JIntArray = JArray ('Prim "int")+type JLongArray = JArray ('Prim "long")+type JFloatArray = JArray ('Prim "float")+type JDoubleArray = JArray ('Prim "double")
+ tests/Foreign/JNISpec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Foreign.JNISpec where++import Control.Concurrent (runInBoundThread)+import Control.Exception (try)+import Data.List (sort)+import Data.Singletons+import Foreign.JNI.Internal (jniMethodToJavaSignature)+import Foreign.JNI.String (fromChars)+import Foreign.JNI.Types+import Foreign.JNI.Unsafe+import qualified Foreign.JNI.Unsafe.Internal as Internal+import Foreign.JNI.Unsafe.Internal.Introspection+import Test.Hspec++spec :: Spec+spec = do+    describe "runInAttachedThread" $ do+      it "can run jni calls in another thread" $+        runInBoundThread $ runInAttachedThread $ do+          jclass <- findClass $+            referenceTypeName (sing :: Sing ('Class "java.lang.Long"))+          deleteLocalRef jclass++      it "is needed to run jni calls in another thread" $+        runInBoundThread $ do+          findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long")))+            `shouldThrow` \ThreadNotAttached -> True++    around_ (runInBoundThread . runInAttachedThread) $ do+      describe "isInstanceOf" $ do+        it "identifies a class name as a String" $ do+          klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long")))+          name <- callObjectMethod klong classGetNameMethod []+          kstring <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.String")))+          isInstanceOf name kstring `shouldReturn` True+        it "identifies a class name as an Object" $ do+          klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long")))+          name <- callObjectMethod klong classGetNameMethod []+          kobject <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Object")))+          isInstanceOf name kobject `shouldReturn` True+        it "doesn't identify a class name as a Long" $ do+          klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long")))+          name <- callObjectMethod klong classGetNameMethod []+          isInstanceOf name klong `shouldReturn` False++      describe "getMethodID" $ do+        it "gives correct hints on a mistake" $ do+          kstring <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.String")))+          let sig = methodSignature [] (sing @('Class "java.lang.String"))+          result <- try $ getMethodID kstring (fromChars "replace") sig+          case result of+            Left e -> do+              sort (noSuchMethodOverloadings e) `shouldBe`+                [ "public java.lang.String java.lang.String.replace(char,char)"+                , "public java.lang.String java.lang.String.replace(java.lang.CharSequence,java.lang.CharSequence)"+                ]+            _ -> expectationFailure "call should have failed with a NoSuchMethod exception"++      describe "jniMethodToJavaSignature" $+        it "converts JNI signatures correctly" $ do+          jniMethodToJavaSignature "()J" `shouldBe` Right ([], "long")+          jniMethodToJavaSignature "(I)B" `shouldBe` Right (["int"], "byte")+          jniMethodToJavaSignature "(SF)V" `shouldBe` Right (["short", "float"], "void")+          jniMethodToJavaSignature "(C[Ljava/lang/String;D)Z"+            `shouldBe` Right (["char", "java.lang.String[]", "double"], "boolean")++      describe "showException" $+        it "correctly displays exceptions" $ do+          kinteger <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Integer")))+          let sig = methodSignature [] (sing :: Sing 'Void)+          result <- try $ Internal.getMethodID kinteger (fromChars "toString") sig+          case result of+            Left (e :: JVMException) -> showException e `shouldReturn` "java.lang.NoSuchMethodError: toString\n"+            _ -> expectationFailure "call should have failed with a JVMException"
+ tests/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Foreign.JNI (withJVM)+import qualified Spec+import Test.Hspec++main :: IO ()+main = withJVM [] $ hspec Spec.spec
+ tests/Spec.hs view
@@ -0,0 +1,2 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -F -pgmF HSPEC_DISCOVER -optF --module-name=Spec #-}