diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright EURL Tweag (c) 2015-2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,59 @@ +# inline-java: Call any JVM function from Haskell + +The Haskell standard includes a native foreign function interface +(FFI). It can be a pain to use and in any case only C support is +implemented in GHC. `inline-java` lets you call any JVM function +directly, from Haskell, without the need to write your own foreign +import declarations using the FFI. In the style of `inline-c` for C and +`inline-r` for calling R, `inline-java` lets you name any function to +call inline in your code. + +**This is an early tech preview, not production ready.** + +**Quasiquotation to make inline calls in Java syntax not yet + implemented. But calls in Haskell syntax supported.** + +# Example + +Graphical Hello World using Java Swing: + +```Haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +import Data.Text (Text) +import Language.Java + +newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) +instance Coercible JOptionPane ('Class "javax.swing.JOptionPane") + +main :: IO () +main = withJVM [] $ do + message <- reflect ("Hello World!" :: Text) + callStatic + (classOf (undefined :: JOptionPane)) + "showMessageDialog" + [JObject nullComponent, JObject (upcast message)] + where + nullComponent :: J ('Class "java.awt.Component") + nullComponent = jnull +``` +## License + +Copyright (c) 2015-2016 EURL Tweag. + +All rights reserved. + +Sparkle is free software, and may be redistributed under the terms +specified in the [LICENSE](LICENSE) file. + +## About + +![Tweag I/O](http://i.imgur.com/0HK8X4y.png) + +Sparkle is maintained by [Tweag I/O](http://tweag.io/). + +Have questions? Need help? Tweet at +[@tweagio](http://twitter.com/tweagio). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/inline-java.cabal b/inline-java.cabal new file mode 100644 --- /dev/null +++ b/inline-java.cabal @@ -0,0 +1,41 @@ +name: inline-java +version: 0.1 +synopsis: Java interop via inline Java code in Haskell modules. +description: Please see README.md. +homepage: http://github.com/tweag/inline-java#readme +license: BSD3 +license-file: LICENSE +author: Tweag I/O +maintainer: alp.mestanogullari@tweag.io +copyright: 2015-2016 EURL Tweag. +category: FFI, JVM, Java +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/tweag/inline-java + +library + hs-source-dirs: src + c-sources: src/Foreign/JNI.c + cc-options: -std=c11 + extra-libraries: jvm + exposed-modules: + Foreign.JNI + Language.Java + other-modules: + Foreign.JNI.Types + build-depends: + base >= 4.7 && < 5, + binary >=0.7, + bytestring >=0.10, + containers >=0.5, + distributed-closure >=0.3, + inline-c >=0.5, + singletons >= 2.0, + text >=1.2, + thread-local-storage >=0.1, + vector >=0.11 + default-language: Haskell2010 diff --git a/src/Foreign/JNI.c b/src/Foreign/JNI.c new file mode 100644 --- /dev/null +++ b/src/Foreign/JNI.c @@ -0,0 +1,353 @@ + +#include + +#include + +#include + +jthrowable inline_c_Foreign_JNI_0_547acbc2ed14c804f8e5133e90bd68e8a83f9c40(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { +return ( (*env_inline_c_0)->ExceptionOccurred(env_inline_c_1) ); +} + + +void inline_c_Foreign_JNI_1_78814a28f200ba50ae6a800d1c57dc6512afa523(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { + (*env_inline_c_0)->ExceptionDescribe(env_inline_c_1) ; +} + + +void inline_c_Foreign_JNI_2_fa3d0bf0766f27928a66a4776f60d76979f8c97d(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { + (*env_inline_c_0)->ExceptionClear(env_inline_c_1) ; +} + + +JNIEnv * inline_c_Foreign_JNI_3_300bcb4b3ee6cf320f3afc172c78066ca8d0d097() { + + jsize num_jvms; + JavaVM *jvm; + /* Assume there's at most one JVM. The current JNI spec (2016) says only + * one JVM per process is supported anyways. */ + JNI_GetCreatedJavaVMs(&jvm, 1, &num_jvms); + JNIEnv *env; + + if(!num_jvms) { + fprintf(stderr, "No JVM has been initialized yet.\n"); + exit(EFAULT); + } + + /* Attach as daemon to match GHC's usual semantics for threads, which are + * daemonic. + */ + (*jvm)->AttachCurrentThreadAsDaemon(jvm, (void**)&env, NULL); + return env; +} + + +JavaVM * inline_c_Foreign_JNI_4_c815bc1d60971caaef72b2be0a16ae8be8624208(int n_inline_c_0, int n_inline_c_1, char ** coptions_inline_c_2, int n_inline_c_3) { + + JavaVM *jvm; + JNIEnv *env; + JavaVMInitArgs vm_args; + JavaVMOption *options = malloc(sizeof(JavaVMOption) * n_inline_c_0); + for(int i = 0; i < n_inline_c_1; i++) + options[0].optionString = coptions_inline_c_2[i]; + vm_args.version = JNI_VERSION_1_6; + vm_args.nOptions = n_inline_c_3; + vm_args.options = options; + vm_args.ignoreUnrecognized = 0; + JNI_CreateJavaVM(&jvm, (void**)&env, &vm_args); + free(options); + return jvm; +} + + +void inline_c_Foreign_JNI_5_b584a6aa1eb7dfd9c78995e2ecba0ce2c820e741(JavaVM * jvm_inline_c_0, JavaVM * jvm_inline_c_1) { + (*jvm_inline_c_0)->DestroyJavaVM(jvm_inline_c_1); +} + + +jclass inline_c_Foreign_JNI_6_8aaec858890db1573fbec87c594caa2d9c2597ac(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, char * name_inline_c_2) { +return ( (*env_inline_c_0)->FindClass(env_inline_c_1, name_inline_c_2) ); +} + + +jobject inline_c_Foreign_JNI_7_db79f2d25dd672f2593a68b078850f23bf59b54d(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID constr_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->NewObjectA(env_inline_c_1, + cls_inline_c_2, + constr_inline_c_3, + cargs_inline_c_4) ); +} + + +jfieldID inline_c_Foreign_JNI_8_47c3da2765e4f1c6c03bb8cdad8bc2d65680370e(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * fieldname_inline_c_3, char * sig_inline_c_4) { +return ( + (*env_inline_c_0)->GetFieldID(env_inline_c_1, + cls_inline_c_2, + fieldname_inline_c_3, + sig_inline_c_4) ); +} + + +jobject inline_c_Foreign_JNI_9_fd81942890ffe8025c7c8e605b29bfa2d631bf64(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jfieldID field_inline_c_3) { +return ( + (*env_inline_c_0)->GetObjectField(env_inline_c_1, + obj_inline_c_2, + field_inline_c_3) ); +} + + +jmethodID inline_c_Foreign_JNI_10_3f3cc5c249c59d38507f1b203b4a80c8a8403f85(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * methodname_inline_c_3, char * sig_inline_c_4) { +return ( + (*env_inline_c_0)->GetMethodID(env_inline_c_1, + cls_inline_c_2, + methodname_inline_c_3, + sig_inline_c_4) ); +} + + +jmethodID inline_c_Foreign_JNI_11_dd0463a591df861dc2b6fe34aa62df3dc045603f(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * methodname_inline_c_3, char * sig_inline_c_4) { +return ( + (*env_inline_c_0)->GetStaticMethodID(env_inline_c_1, + cls_inline_c_2, + methodname_inline_c_3, + sig_inline_c_4) ); +} + + +jobject inline_c_Foreign_JNI_12_55bd50e01b2763f523b25ff19116b87a438f4472(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallObjectMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +jboolean inline_c_Foreign_JNI_13_51921259d227ba170aa0d559535ed1fbc1efe9b0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallBooleanMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +jint inline_c_Foreign_JNI_14_d28a2420a47367a1c33fcdd13134997b927047e0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallIntMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +jlong inline_c_Foreign_JNI_15_032fac443ca3e2d4cdd76787a46cab093f442894(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallLongMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +jbyte inline_c_Foreign_JNI_16_8d0dd9482faf1553b421b56cad3ec4f0ca4417b0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallByteMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +jdouble inline_c_Foreign_JNI_17_97e7fa4f2b0ebaa3ecd3d3eb159d181f5dd74d88(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallDoubleMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +void inline_c_Foreign_JNI_18_882269bf6cfb8dadd0713420cf481299a2626392(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { + + (*env_inline_c_0)->CallVoidMethodA(env_inline_c_1, + obj_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ; +} + + +jobject inline_c_Foreign_JNI_19_8db89b53df84629890dfd632bb1cf065581e5658(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { +return ( + (*env_inline_c_0)->CallStaticObjectMethodA(env_inline_c_1, + cls_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ); +} + + +void inline_c_Foreign_JNI_20_07d8ef24eefeeb4e75fc82280b5661d536563284(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { + + (*env_inline_c_0)->CallStaticVoidMethodA(env_inline_c_1, + cls_inline_c_2, + method_inline_c_3, + cargs_inline_c_4) ; +} + + +jintArray inline_c_Foreign_JNI_21_fed08588a63cb947275fb36261f23e1b734a77a7(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { +return ( + (*env_inline_c_0)->NewIntArray(env_inline_c_1, + sz_inline_c_2) ); +} + + +jbyteArray inline_c_Foreign_JNI_22_b35c0a12df8861976445a64e0ad8fa9a734b69f2(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { +return ( + (*env_inline_c_0)->NewByteArray(env_inline_c_1, + sz_inline_c_2) ); +} + + +jdoubleArray inline_c_Foreign_JNI_23_fa58b230f44695586d4bf7408ef11a9119d58791(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { +return ( + (*env_inline_c_0)->NewDoubleArray(env_inline_c_1, + sz_inline_c_2) ); +} + + +jobjectArray inline_c_Foreign_JNI_24_0b57533e83360b5a6660bf703521b3b6c2fbec66(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2, jclass cls_inline_c_3) { +return ( + (*env_inline_c_0)->NewObjectArray(env_inline_c_1, + sz_inline_c_2, + cls_inline_c_3, + NULL) ); +} + + +jstring inline_c_Foreign_JNI_25_d5ed5b314231e7dc3292c2329a2cb4191e262633(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jchar * ptr_inline_c_2, jsize len_inline_c_3) { +return ( + (*env_inline_c_0)->NewString(env_inline_c_1, + ptr_inline_c_2, + len_inline_c_3) ); +} + + +jsize inline_c_Foreign_JNI_26_9be0134c89fa74c4d07a2601d81d89982ce8bdf6(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jarray array_inline_c_2) { +return ( + (*env_inline_c_0)->GetArrayLength(env_inline_c_1, + array_inline_c_2) ); +} + + +jsize inline_c_Foreign_JNI_27_2e55ce4ded52c43b7b69c0c49c4425aef4f8a80b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2) { +return ( + (*env_inline_c_0)->GetStringLength(env_inline_c_1, + jstr_inline_c_2) ); +} + + +jint * inline_c_Foreign_JNI_28_9f5fde34ac136fbf3999d5fd83bf8c6795691309(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2) { +return ( + (*env_inline_c_0)->GetIntArrayElements(env_inline_c_1, + array_inline_c_2, + NULL) ); +} + + +jbyte * inline_c_Foreign_JNI_29_cdab9b47790cf35ecdf9048aa91a969b02a442d4(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2) { +return ( + (*env_inline_c_0)->GetByteArrayElements(env_inline_c_1, + array_inline_c_2, + NULL) ); +} + + +jdouble * inline_c_Foreign_JNI_30_0a74ecc228388d392854113c321eb33afd35fbe9(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jdoubleArray array_inline_c_2) { +return ( + (*env_inline_c_0)->GetDoubleArrayElements(env_inline_c_1, + array_inline_c_2, + NULL) ); +} + + +const jchar * inline_c_Foreign_JNI_31_ac075a3bdcb535575fe36c6f7b5eb3d66ace44a7(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2) { +return ( + (*env_inline_c_0)->GetStringChars(env_inline_c_1, + jstr_inline_c_2, + NULL) ); +} + + +void inline_c_Foreign_JNI_32_cd71790439f2d5820b4dd729a7d949947700110b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jint * buf_inline_c_5) { + + (*env_inline_c_0)->SetIntArrayRegion(env_inline_c_1, + array_inline_c_2, + start_inline_c_3, + len_inline_c_4, + buf_inline_c_5) ; +} + + +void inline_c_Foreign_JNI_33_dc2c381ced7a286daea5604a5b0dc88ea6551f8b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jbyte * buf_inline_c_5) { + + (*env_inline_c_0)->SetByteArrayRegion(env_inline_c_1, + array_inline_c_2, + start_inline_c_3, + len_inline_c_4, + buf_inline_c_5) ; +} + + +void inline_c_Foreign_JNI_34_183036c6396218e335fec7293ba5fa90e82e8432(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jdoubleArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jdouble * buf_inline_c_5) { + + (*env_inline_c_0)->SetDoubleArrayRegion(env_inline_c_1, + array_inline_c_2, + start_inline_c_3, + len_inline_c_4, + buf_inline_c_5) ; +} + + +void inline_c_Foreign_JNI_35_c7418bff62dd9478672b34cf2bf3839b0e070775(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2, jint * xs_inline_c_3) { + + (*env_inline_c_0)->ReleaseIntArrayElements(env_inline_c_1, + array_inline_c_2, + xs_inline_c_3, + JNI_ABORT) ; +} + + +void inline_c_Foreign_JNI_36_cda4e05286c2fbcddb139b19baec3a7cc27dc3a9(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2, jbyte * xs_inline_c_3) { + + (*env_inline_c_0)->ReleaseByteArrayElements(env_inline_c_1, + array_inline_c_2, + xs_inline_c_3, + JNI_ABORT) ; +} + + +void inline_c_Foreign_JNI_37_7a962d5f8e6114066dca42386535e4a079022eae(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2, jchar * chars_inline_c_3) { + + (*env_inline_c_0)->ReleaseStringChars(env_inline_c_1, + jstr_inline_c_2, + chars_inline_c_3) ; +} + + +jobject inline_c_Foreign_JNI_38_bb66272284cce01d85b6ec31967e1a66eae7e0c5(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jarray array_inline_c_2, jsize i_inline_c_3) { +return ( + (*env_inline_c_0)->GetObjectArrayElement(env_inline_c_1, + array_inline_c_2, + i_inline_c_3) ); +} + + +void inline_c_Foreign_JNI_39_c069b4edd080791f4858d4a7a48b8c42c99c8e4a(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobjectArray array_inline_c_2, jsize i_inline_c_3, jobject x_inline_c_4) { + + (*env_inline_c_0)->SetObjectArrayElement(env_inline_c_1, + array_inline_c_2, + i_inline_c_3, + x_inline_c_4); ; +} + diff --git a/src/Foreign/JNI.hs b/src/Foreign/JNI.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/JNI.hs @@ -0,0 +1,477 @@ +-- | Low-level bindings to the Java Native Interface (JNI). +-- +-- Read the +-- +-- 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. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Foreign.JNI + ( module Foreign.JNI.Types + -- * JNI functions + -- ** VM creation + , withJVM + -- ** Query functions + , findClass + , getFieldID + , getObjectField + , getMethodID + , getStaticMethodID + -- ** Method invocation + , callObjectMethod + , callBooleanMethod + , callIntMethod + , callLongMethod + , callByteMethod + , callDoubleMethod + , callVoidMethod + , callStaticObjectMethod + , callStaticVoidMethod + -- ** Object construction + , newObject + , newIntArray + , newDoubleArray + , newByteArray + , newObjectArray + , newString + -- ** Array manipulation + , getArrayLength + , getStringLength + , getIntArrayElements + , getByteArrayElements + , getDoubleArrayElements + , getStringChars + , setIntArrayRegion + , setByteArrayRegion + , setDoubleArrayRegion + , releaseIntArrayElements + , releaseByteArrayElements + , releaseStringChars + , getObjectArrayElement + , setObjectArrayElement + ) where + +import Control.Exception (Exception, bracket, finally, throwIO) +import Control.Monad (unless) +import Data.Coerce +import Data.Int +import Data.IORef (IORef, newIORef, readIORef) +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) +import Data.TLS.PThread +import Foreign.C (CChar) +import Foreign.JNI.Types +import Foreign.Marshal.Array +import Foreign.Ptr (Ptr, nullPtr) +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Unsafe as CU +import System.IO.Unsafe (unsafePerformIO) + +C.context (C.baseCtx <> C.bsCtx <> jniCtx) + +C.include "" +C.include "" +C.include "" + +data JavaException = JavaException JThrowable + deriving (Show, Typeable) + +instance Exception JavaException + +-- | Thrown when @GetArrayElements@ 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 (Show, Typeable) + +instance Exception ArrayCopyFailed + +-- | Map Java exceptions to Haskell exceptions. +throwIfException :: Ptr JNIEnv -> IO a -> IO a +throwIfException env m = m `finally` do + J 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 $ JavaException (J 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 + +-- | A global mutable cell holding the TLS variable, whose content is set once +-- for each thread. +envTlsRef :: IORef (TLS (Ptr JNIEnv)) +{-# NOINLINE envTlsRef #-} +envTlsRef = unsafePerformIO $ do + -- It doesn't matter if this computation ends up running twice, say because + -- of lazy blackholing. + !tls <- mkTLS $ [C.block| JNIEnv* { + jsize num_jvms; + JavaVM *jvm; + /* Assume there's at most one JVM. The current JNI spec (2016) says only + * one JVM per process is supported anyways. */ + JNI_GetCreatedJavaVMs(&jvm, 1, &num_jvms); + JNIEnv *env; + + if(!num_jvms) { + fprintf(stderr, "No JVM has been initialized yet.\n"); + exit(EFAULT); + } + + /* Attach as daemon to match GHC's usual semantics for threads, which are + * daemonic. + */ + (*jvm)->AttachCurrentThreadAsDaemon(jvm, (void**)&env, NULL); + return env; } |] + newIORef tls + +-- | Run an action against the appropriate 'JNIEnv'. +-- +-- Each OS thread has its own 'JNIEnv', which this function gives access to. +-- +-- TODO check whether this call is only safe from a (bound) thread. +withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a +withJNIEnv f = f =<< getTLS =<< readIORef envTlsRef + +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 it to wrap your @main@ function. +withJVM :: [ByteString] -> IO () -> IO () +withJVM options action = + bracket ini fini (const action) + where + ini = do + useAsCStrings options $ \cstrs -> do + withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do + let n = fromIntegral (length cstrs) :: C.CInt + [C.block| JavaVM * { + JavaVM *jvm; + JNIEnv *env; + JavaVMInitArgs vm_args; + JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n)); + for(int i = 0; i < $(int n); i++) + options[0].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**)&env, &vm_args); + free(options); + return jvm; } |] + fini jvm = [C.block| void { (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm)); } |] + +findClass :: ByteString -> IO JClass +findClass name = withJNIEnv $ \env -> + throwIfException env $ + [C.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $bs-ptr:name) } |] + +newObject :: JClass -> ByteString -> [JValue] -> IO JObject +newObject cls sig args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> do + constr <- getMethodID cls "" sig + [CU.exp| jobject { + (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env), + $(jclass cls), + $(jmethodID constr), + $(jvalue *cargs)) } |] + +getFieldID :: JClass -> ByteString -> ByteString -> IO JFieldID +getFieldID cls fieldname sig = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jfieldID { + (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env), + $(jclass cls), + $bs-ptr:fieldname, + $bs-ptr:sig) } |] + +getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject +getObjectField (coerce -> upcast -> obj) field = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jobject { + (*$(JNIEnv *env))->GetObjectField($(JNIEnv *env), + $(jobject obj), + $(jfieldID field)) } |] + +getMethodID :: JClass -> ByteString -> ByteString -> IO JMethodID +getMethodID cls methodname sig = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jmethodID { + (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env), + $(jclass cls), + $bs-ptr:methodname, + $bs-ptr:sig) } |] + +getStaticMethodID :: JClass -> ByteString -> ByteString -> IO JMethodID +getStaticMethodID cls methodname sig = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jmethodID { + (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env), + $(jclass cls), + $bs-ptr:methodname, + $bs-ptr:sig) } |] + +callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject +callObjectMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jobject { + (*$(JNIEnv *env))->CallObjectMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool +callBooleanMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + fmap (toEnum . fromIntegral) $ withArray args $ \cargs -> + [C.exp| jboolean { + (*$(JNIEnv *env))->CallBooleanMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callIntMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Int32 +callIntMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jint { + (*$(JNIEnv *env))->CallIntMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callLongMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Int64 +callLongMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jlong { + (*$(JNIEnv *env))->CallLongMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callByteMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO CChar +callByteMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jbyte { + (*$(JNIEnv *env))->CallByteMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callDoubleMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Double +callDoubleMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jdouble { + (*$(JNIEnv *env))->CallDoubleMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callVoidMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO () +callVoidMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| void { + (*$(JNIEnv *env))->CallVoidMethodA($(JNIEnv *env), + $(jobject obj), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject +callStaticObjectMethod cls method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| jobject { + (*$(JNIEnv *env))->CallStaticObjectMethodA($(JNIEnv *env), + $(jclass cls), + $(jmethodID method), + $(jvalue *cargs)) } |] + +callStaticVoidMethod :: JClass -> JMethodID -> [JValue] -> IO () +callStaticVoidMethod cls method args = withJNIEnv $ \env -> + throwIfException env $ + withArray args $ \cargs -> + [C.exp| void { + (*$(JNIEnv *env))->CallStaticVoidMethodA($(JNIEnv *env), + $(jclass cls), + $(jmethodID method), + $(jvalue *cargs)) } |] + +newIntArray :: Int32 -> IO JIntArray +newIntArray sz = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jintArray { + (*$(JNIEnv *env))->NewIntArray($(JNIEnv *env), + $(jsize sz)) } |] + +newByteArray :: Int32 -> IO JByteArray +newByteArray sz = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jbyteArray { + (*$(JNIEnv *env))->NewByteArray($(JNIEnv *env), + $(jsize sz)) } |] + +newDoubleArray :: Int32 -> IO JDoubleArray +newDoubleArray sz = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jdoubleArray { + (*$(JNIEnv *env))->NewDoubleArray($(JNIEnv *env), + $(jsize sz)) } |] + +newObjectArray :: Int32 -> JClass -> IO JObjectArray +newObjectArray sz cls = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jobjectArray { + (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env), + $(jsize sz), + $(jclass cls), + NULL) } |] + +newString :: Ptr Word16 -> Int32 -> IO JString +newString ptr len = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| jstring { + (*$(JNIEnv *env))->NewString($(JNIEnv *env), + $(jchar *ptr), + $(jsize len)) } |] + +getArrayLength :: Coercible o (JArray a) => o -> IO Int32 +getArrayLength (coerce -> upcast -> array) = withJNIEnv $ \env -> + [C.exp| jsize { + (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env), + $(jarray array)) } |] + +getStringLength :: JString -> IO Int32 +getStringLength jstr = withJNIEnv $ \env -> + [CU.exp| jsize { + (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env), + $(jstring jstr)) } |] + +getIntArrayElements :: JIntArray -> IO (Ptr Int32) +getIntArrayElements array = withJNIEnv $ \env -> + throwIfNull $ + [CU.exp| jint* { + (*$(JNIEnv *env))->GetIntArrayElements($(JNIEnv *env), + $(jintArray array), + NULL) } |] + +getByteArrayElements :: JByteArray -> IO (Ptr CChar) +getByteArrayElements array = withJNIEnv $ \env -> + throwIfNull $ + [CU.exp| jbyte* { + (*$(JNIEnv *env))->GetByteArrayElements($(JNIEnv *env), + $(jbyteArray array), + NULL) } |] + +getDoubleArrayElements :: JDoubleArray -> IO (Ptr Double) +getDoubleArrayElements array = withJNIEnv $ \env -> + throwIfNull $ + [CU.exp| jdouble* { + (*$(JNIEnv *env))->GetDoubleArrayElements($(JNIEnv *env), + $(jdoubleArray array), + NULL) } |] + +getStringChars :: JString -> IO (Ptr Word16) +getStringChars jstr = withJNIEnv $ \env -> + throwIfNull $ + [CU.exp| const jchar* { + (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env), + $(jstring jstr), + NULL) } |] + +setIntArrayRegion :: JIntArray -> Int32 -> Int32 -> Ptr Int32 -> IO () +setIntArrayRegion array start len buf = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| void { + (*$(JNIEnv *env))->SetIntArrayRegion($(JNIEnv *env), + $(jintArray array), + $(jsize start), + $(jsize len), + $(jint *buf)) } |] + +setByteArrayRegion :: JByteArray -> Int32 -> Int32 -> Ptr CChar -> IO () +setByteArrayRegion array start len buf = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| void { + (*$(JNIEnv *env))->SetByteArrayRegion($(JNIEnv *env), + $(jbyteArray array), + $(jsize start), + $(jsize len), + $(jbyte *buf)) } |] + +setDoubleArrayRegion :: JDoubleArray -> Int32 -> Int32 -> Ptr Double -> IO () +setDoubleArrayRegion array start len buf = withJNIEnv $ \env -> + throwIfException env $ + [CU.exp| void { + (*$(JNIEnv *env))->SetDoubleArrayRegion($(JNIEnv *env), + $(jdoubleArray array), + $(jsize start), + $(jsize len), + $(jdouble *buf)) } |] + +releaseIntArrayElements :: JIntArray -> Ptr Int32 -> IO () +releaseIntArrayElements array xs = withJNIEnv $ \env -> + [CU.exp| void { + (*$(JNIEnv *env))->ReleaseIntArrayElements($(JNIEnv *env), + $(jintArray array), + $(jint *xs), + JNI_ABORT) } |] + +releaseByteArrayElements :: JByteArray -> Ptr CChar -> IO () +releaseByteArrayElements array xs = withJNIEnv $ \env -> + [CU.exp| void { + (*$(JNIEnv *env))->ReleaseByteArrayElements($(JNIEnv *env), + $(jbyteArray array), + $(jbyte *xs), + JNI_ABORT) } |] + +releaseStringChars :: JString -> Ptr Word16 -> IO () +releaseStringChars jstr chars = withJNIEnv $ \env -> + [CU.exp| void { + (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env), + $(jstring jstr), + $(jchar *chars)) } |] + +getObjectArrayElement :: Coercible o (JArray a) => o -> Int32 -> IO (J a) +getObjectArrayElement (coerce -> upcast -> array) i = withJNIEnv $ \env -> unsafeCast <$> + [C.exp| jobject { + (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env), + $(jarray array), + $(jsize i)) } |] + +setObjectArrayElement :: Coercible o (J a) => JObjectArray -> Int32 -> o -> IO () +setObjectArrayElement array i (coerce -> upcast -> x) = withJNIEnv $ \env -> + [C.exp| void { + (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env), + $(jobjectArray array), + $(jsize i), + $(jobject x)); } |] diff --git a/src/Foreign/JNI/Types.hs b/src/Foreign/JNI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/JNI/Types.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} -- For J a +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Foreign.JNI.Types + ( JType(..) + , Sing(..) + , type (<>) + -- * JNI types + , J(..) + , jnull + , upcast + , unsafeCast + , generic + , unsafeUngeneric + , jtypeOf + , signature + , methodSignature + , JVM(..) + , JNIEnv(..) + , JMethodID(..) + , JFieldID(..) + , JValue(..) + -- * JNI defined object types + , JObject + , JClass + , JString + , JArray + , JObjectArray + , JBooleanArray + , JByteArray + , JCharArray + , JShortArray + , JIntArray + , JLongArray + , JFloatArray + , JDoubleArray + , JThrowable + -- * inline-c contexts + , jniCtx + ) where + +import qualified Data.ByteString.Char8 as BS +import Data.ByteString (ByteString) +import Data.Int +import Data.Map (fromList) +import Data.Singletons (Sing, SingI(..), SomeSing(..), KProxy(..)) +import Data.Singletons.TypeLits (KnownSymbol, symbolVal) +import Data.Word +import Foreign.C (CChar) +import Foreign.Ptr +import Foreign.Storable (Storable(..)) +import GHC.TypeLits (Symbol) +import Language.C.Types (TypeSpecifier(TypeName)) +import Language.C.Inline.Context (Context(..)) + +-- | A JVM instance. +newtype JVM = JVM_ (Ptr JVM) + deriving (Eq, Show, Storable) + +-- | The thread-local JNI context. Do not share this object between threads. +newtype JNIEnv = JNIEnv_ (Ptr JNIEnv) + deriving (Eq, Show, Storable) + +-- | A thread-local reference to a field of an object. +newtype JFieldID = JFieldID_ (Ptr JFieldID) + deriving (Eq, Show, Storable) + +-- | A thread-local reference to a method of an object. +newtype JMethodID = JMethodID_ (Ptr JMethodID) + deriving (Eq, Show, Storable) + +-- | Not part of JNI. Kind of Java object type indexes. +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 + +data instance Sing (a :: JType) where + SClass :: ByteString -> Sing ('Class sym) + SIface :: ByteString -> Sing ('Iface sym) + SPrim :: ByteString -> Sing ('Prim sym) + -- XXX SingI constraint temporary hack because GHC 7.10 has trouble inferring + -- this constraint in 'signature'. + SArray :: Sing ty -> Sing ('Array ty) + SGeneric :: Sing ty -> Sing tys -> Sing ('Generic ty tys) + SVoid :: Sing 'Void + +instance (KnownSymbol sym, SingI sym) => SingI ('Class (sym :: Symbol)) where + sing = SClass (BS.pack $ symbolVal (undefined :: proxy sym)) +instance (KnownSymbol sym, SingI sym) => SingI ('Iface (sym :: Symbol)) where + sing = SIface (BS.pack $ symbolVal (undefined :: proxy sym)) +instance (KnownSymbol sym, SingI sym) => SingI ('Prim (sym :: Symbol)) where + sing = SPrim (BS.pack $ 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 (Ptr (J a)) + deriving (Eq, Show, Storable) + +type role J representational + +jnull :: J a +jnull = J nullPtr + +-- | Any object can be cast to @Object@. +upcast :: J a -> JObject +upcast = unsafeCast + +-- | Unsafe type cast. Should only be used to downcast. +unsafeCast :: J a -> J b +unsafeCast (J x) = J (castPtr 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 Int8 + | 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)) = castPtr x == castPtr y + _ == _ = False + +instance Storable JValue where + sizeOf _ = 8 + alignment _ = 8 + + poke p (JBoolean x) = poke (castPtr p) x + poke p (JByte x) = poke (castPtr p) x + poke p (JChar x) = poke (castPtr p) x + poke p (JShort x) = poke (castPtr p) x + poke p (JInt x) = poke (castPtr p) x + poke p (JLong x) = poke (castPtr p) x + poke p (JFloat x) = poke (castPtr p) x + poke p (JDouble x) = poke (castPtr p) x + poke p (JObject x) = poke (castPtr p :: Ptr (J a)) x + + peek _ = error "Storable JValue: undefined peek" + +jtypeOf :: JValue -> SomeSing ('KProxy :: KProxy 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) + +signature :: Sing (ty :: JType) -> ByteString +signature (SClass sym) = "L" `BS.append` BS.map subst sym `BS.append` ";" + where subst '.' = '/'; subst x = x +signature (SIface sym) = "L" `BS.append` BS.map subst sym `BS.append` ";" + where subst '.' = '/'; subst x = x +signature (SPrim "boolean") = "Z" +signature (SPrim "byte") = "B" +signature (SPrim "char") = "C" +signature (SPrim "short") = "S" +signature (SPrim "int") = "I" +signature (SPrim "long") = "J" +signature (SPrim "float") = "F" +signature (SPrim "double") = "D" +signature (SPrim sym) = error $ "Unknown primitive: " ++ BS.unpack sym +signature (SArray ty) = "[" `BS.append` signature ty +signature (SGeneric ty _) = signature ty +signature SVoid = "V" + +methodSignature + :: [SomeSing ('KProxy :: KProxy JType)] + -> Sing (ty :: JType) + -> ByteString +methodSignature args ret = + "(" `BS.append` + BS.concat (map (\(SomeSing s) -> signature s) args) `BS.append` + ")" `BS.append` + signature ret + +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 = fromList tytab } + 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| JObject |]) + , (TypeName "jclass", [t| JClass |]) + , (TypeName "jstring", [t| JString |]) + , (TypeName "jarray", [t| JObject |]) + , (TypeName "jobjectArray", [t| JObjectArray |]) + , (TypeName "jbooleanArray", [t| JBooleanArray |]) + , (TypeName "jbyteArray", [t| JByteArray |]) + , (TypeName "jcharArray", [t| JCharArray |]) + , (TypeName "jshortArray", [t| JShortArray |]) + , (TypeName "jintArray", [t| JIntArray |]) + , (TypeName "jlongArray", [t| JLongArray |]) + , (TypeName "jfloatArray", [t| JFloatArray |]) + , (TypeName "jdoubleArray", [t| JDoubleArray |]) + , (TypeName "jthrowable", [t| JThrowable |]) + -- Internal types + , (TypeName "JavaVM", [t| JVM |]) + , (TypeName "JNIEnv", [t| JNIEnv |]) + , (TypeName "jfieldID", [t| JFieldID |]) + , (TypeName "jmethodID", [t| JMethodID |]) + , (TypeName "jsize", [t| Int32 |]) + , (TypeName "jvalue", [t| JValue |]) + ] diff --git a/src/Language/Java.hs b/src/Language/Java.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java.hs @@ -0,0 +1,384 @@ +-- | High-level helper functions for interacting with Java objects, mapping them +-- to Haskell values and vice versa. The 'Reify' and 'Reflect' classes together +-- are to Java what "Foreign.Storable" is to C: they provide a means to +-- marshall/unmarshall Java objects from/into Haskell data types. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Java + ( module Foreign.JNI.Types + , withJVM + , Coercible(..) + , classOf + , new + , call + , callStatic + , Type(..) + , Uncurry + , Interp + , Reify(..) + , Reflect(..) + , sing + ) where + +import Control.Distributed.Closure +import Control.Distributed.Closure.TH +import Control.Monad ((<=<), forM, forM_) +import Data.Char (chr, ord) +import qualified Data.Coerce as Coerce +import Data.Int +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Unsafe as BS +import Data.Singletons (SingI(..), fromSing) +import qualified Data.Text.Foreign as Text +import Data.Text (Text) +import qualified Data.Vector.Storable as Vector +import Data.Vector.Storable (Vector) +import qualified Data.Vector.Storable.Mutable as MVector +import Data.Vector.Storable.Mutable (IOVector) +import Foreign (FunPtr, Ptr, Storable, newForeignPtr, withForeignPtr) +import Foreign.C (CChar) +import Foreign.JNI +import Foreign.JNI.Types +import GHC.TypeLits (KnownSymbol, Symbol) + +-- | Tag data types that can be coerced in O(1) time without copy to a Java +-- object or primitive type (i.e. have the same representation) by declaring an +-- instance of this type class for that data type. +class SingI ty => Coercible a (ty :: JType) | a -> ty where + coerce :: a -> JValue + unsafeUncoerce :: JValue -> a + + default coerce + :: Coerce.Coercible a (J ty) + => a + -> JValue + coerce x = JObject (Coerce.coerce x :: J ty) + + default unsafeUncoerce + :: Coerce.Coercible (J ty) a + => JValue + -> a + unsafeUncoerce (JObject obj) = Coerce.coerce (unsafeCast obj :: J ty) + unsafeUncoerce _ = + error "Cannot unsafeUncoerce: object expected but value of primitive type found." + +-- | The identity instance. +instance SingI ty => Coercible (J ty) ty + +instance Coercible Bool ('Prim "boolean") where + coerce x = JBoolean (fromIntegral (fromEnum x)) + unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible CChar ('Prim "byte") where + coerce = JByte + unsafeUncoerce (JByte x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Char ('Prim "char") where + coerce x = JChar (fromIntegral (ord x)) + unsafeUncoerce (JChar x) = chr (fromIntegral x) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Int8 ('Prim "short") where + coerce = JShort + unsafeUncoerce (JShort x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Int32 ('Prim "int") where + coerce = JInt + unsafeUncoerce (JInt x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Int64 ('Prim "long") where + coerce = JLong + unsafeUncoerce (JLong x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Float ('Prim "float") where + coerce = JFloat + unsafeUncoerce (JFloat x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible Double ('Prim "double") where + coerce = JDouble + unsafeUncoerce (JDouble x) = x + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." +instance Coercible () 'Void where + coerce = error "Void value undefined." + unsafeUncoerce _ = () + +classOf + :: ( Coerce.Coercible a (J ('Class sym)) + , Coercible a ('Class sym) + , KnownSymbol sym + ) + => a + -> Sing sym +classOf _ = sing + +-- | NULL terminate byte strings, because those that were not created from +-- statically allocated literals aren't guaranteed to be. +nullTerminate :: ByteString -> ByteString +nullTerminate = (`BS.snoc` '\0') + +-- | FindClass() special cases class names: in that case it doesn't want +-- a full signature, just the class name. +signatureStrip :: ByteString -> ByteString +signatureStrip sig | Just ('L', cls) <- BS.uncons sig = BS.init cls +signatureStrip sig = sig + +-- | Creates a new instance of the class whose name is resolved from the return +-- type. +new + :: forall a sym. + ( Coerce.Coercible a (J ('Class sym)) + , Coercible a ('Class sym) + , KnownSymbol sym + ) + => [JValue] + -> IO a +new args = do + let argsings = map jtypeOf args + voidsing = sing :: Sing 'Void + klass <- findClass (nullTerminate (signatureStrip (signature (sing :: Sing ('Class sym))))) + Coerce.coerce <$> newObject klass (nullTerminate (methodSignature argsings voidsing)) args + +-- | The Swiss Army knife for calling Java methods. Give it an object or +-- any data type coercible to one, the name of a method, and a list of +-- arguments. Based on the type indexes of each argument, and based on the +-- return type, 'call' will invoke the named method using of the @call*Method@ +-- family of functions in the JNI API. +-- +-- When the method name is overloaded, use 'upcast' or 'unsafeCast' +-- appropriately on the class instance and/or on the arguments to invoke the +-- right method. +call + :: forall a b ty1 ty2. (Coercible a ty1, Coercible b ty2, Coerce.Coercible a (J ty1)) + => a + -> ByteString + -> [JValue] + -> IO b +call obj mname args = do + let argsings = map jtypeOf args + retsing = sing :: Sing ty2 + klass <- findClass (nullTerminate (signatureStrip (signature (sing :: Sing ty1)))) + method <- getMethodID klass mname (nullTerminate (methodSignature argsings retsing)) + case retsing of + SPrim "boolean" -> unsafeUncoerce . coerce <$> callBooleanMethod obj method args + SPrim "byte" -> unsafeUncoerce . coerce <$> callByteMethod obj method args + SPrim "char" -> error "call: unimplemented" + SPrim "short" -> error "call: unimplemented" + SPrim "int" -> unsafeUncoerce . coerce <$> callIntMethod obj method args + SPrim "long" -> unsafeUncoerce . coerce <$> callLongMethod obj method args + SPrim "float" -> error "call: unimplemented" + SPrim "double" -> unsafeUncoerce . coerce <$> callDoubleMethod obj method args + SVoid -> do + callVoidMethod obj method args + -- Anything uncoerces to the void type. + return (unsafeUncoerce undefined) + _ -> unsafeUncoerce . coerce <$> callObjectMethod obj method args + +-- | Same as 'call', but for static methods. +callStatic :: forall a ty sym. Coercible a ty => Sing (sym :: Symbol) -> ByteString -> [JValue] -> IO a +callStatic cname mname args = do + let argsings = map jtypeOf args + retsing = sing :: Sing ty + klass <- findClass (nullTerminate (BS.pack (map subst (fromSing cname)))) + method <- getStaticMethodID klass mname (nullTerminate (methodSignature argsings retsing)) + case retsing of + SPrim "boolean" -> error "callStatic: unimplemented" + SPrim "byte" -> error "callStatic: unimplemented" + SPrim "char" -> error "callStatic: unimplemented" + SPrim "short" -> error "callStatic: unimplemented" + SPrim "int" -> error "callStatic: unimplemented" + SPrim "long" -> error "callStatic: unimplemented" + SPrim "float" -> error "callStatic: unimplemented" + SPrim "double" -> error "callStatic: unimplemented" + SVoid -> do + callStaticVoidMethod klass method args + -- Anything uncoerces to the void type. + return (unsafeUncoerce undefined) + _ -> unsafeUncoerce . coerce <$> callStaticObjectMethod klass method args + where + subst '.' = '/' + subst x = x + +-- | Classifies Java types according to whether they are base types (data) or +-- higher-order types (objects representing functions). +data Type a + = Fun [Type a] (Type a) -- ^ Pure function + | Act [Type a] (Type a) -- ^ IO action + | Proc [Type a] -- ^ Procedure (i.e void returning action) + | Base a -- ^ Any first-order type. + +-- | Haskell functions are curried, but Java functions are not. This type family +-- maps Haskell types to an uncurried (non-inductive) type representation, +-- useful to select the right 'Reify' / 'Reflect' instance without overlap. +type family Uncurry (a :: *) :: Type * where + Uncurry (Closure (a -> b -> c -> d -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] + Uncurry (Closure (a -> b -> c -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c] + Uncurry (Closure (a -> b -> IO ())) = 'Proc '[Uncurry a, Uncurry b] + Uncurry (Closure (a -> IO ())) = 'Proc '[Uncurry a] + Uncurry (IO ()) = 'Proc '[] + Uncurry (Closure (a -> b -> c -> d -> IO e)) = 'Act '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e) + Uncurry (Closure (a -> b -> c -> IO d)) = 'Act '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d) + Uncurry (Closure (a -> b -> IO c)) = 'Act '[Uncurry a, Uncurry b] (Uncurry c) + Uncurry (Closure (a -> IO b)) = 'Act '[Uncurry a] (Uncurry b) + Uncurry (Closure (IO a)) = 'Act '[] (Uncurry a) + Uncurry (Closure (a -> b -> c -> d -> e)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e) + Uncurry (Closure (a -> b -> c -> d)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d) + Uncurry (Closure (a -> b -> c)) = 'Fun '[Uncurry a, Uncurry b] (Uncurry c) + Uncurry (Closure (a -> b)) = 'Fun '[Uncurry a] (Uncurry b) + Uncurry a = 'Base a + +-- | Map a Haskell type to the symbolic representation of a Java type. +type family Interp (a :: k) :: JType +type instance Interp ('Base a) = Interp a + +-- | Extract a concrete Haskell value from the space of Java objects. That is to +-- say, map a Java object to a Haskell value. +class (Interp (Uncurry a) ~ ty, SingI ty) => Reify a ty where + reify :: J ty -> IO a + +-- | Inject a concrete Haskell value into the space of Java objects. That is to +-- say, map a Haskell value to a Java object. +class (Interp (Uncurry a) ~ ty, SingI ty) => Reflect a ty where + reflect :: a -> IO (J ty) + +foreign import ccall "wrapper" wrapFinalizer + :: (Ptr a -> IO ()) + -> IO (FunPtr (Ptr a -> IO ())) + +reifyMVector + :: Storable a + => (JArray ty -> IO (Ptr a)) + -> (JArray ty -> Ptr a -> IO ()) + -> JArray ty + -> IO (IOVector a) +reifyMVector mk finalize jobj = do + n <- getArrayLength jobj + ptr <- mk jobj + ffinalize <- wrapFinalizer (finalize jobj) + fptr <- newForeignPtr ffinalize ptr + return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) + +reflectMVector + :: Storable a + => (Int32 -> IO (JArray ty)) + -> (JArray ty -> Int32 -> Int32 -> Ptr a -> IO ()) + -> IOVector a + -> IO (JArray ty) +reflectMVector newfun fill mv = do + let (fptr, n) = MVector.unsafeToForeignPtr0 mv + jobj <- newfun (fromIntegral n) + withForeignPtr fptr $ fill jobj 0 (fromIntegral n) + return jobj + +withStatic [d| + type instance Interp ByteString = 'Array ('Prim "byte") + + instance Reify ByteString ('Array ('Prim "byte")) where + reify jobj = do + n <- getArrayLength (unsafeCast jobj) + bytes <- getByteArrayElements jobj + -- TODO could use unsafePackCStringLen instead and avoid a copy if we knew + -- that been handed an (immutable) copy via JNI isCopy ref. + bs <- BS.packCStringLen (bytes, fromIntegral n) + releaseByteArrayElements jobj bytes + return bs + + instance Reflect ByteString ('Array ('Prim "byte")) where + reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do + arr <- newByteArray (fromIntegral n) + setByteArrayRegion arr 0 (fromIntegral n) content + return arr + + type instance Interp Bool = 'Class "java.lang.Boolean" + + instance Reify Bool ('Class "java.lang.Boolean") where + reify jobj = do + klass <- findClass "java/lang/Boolean" + method <- getMethodID klass "booleanValue" "()Z" + callBooleanMethod jobj method [] + + instance Reflect Bool ('Class "java.lang.Boolean") where + reflect x = new [JBoolean (fromIntegral (fromEnum x))] + + type instance Interp Int = 'Class "java.lang.Integer" + + instance Reify Int ('Class "java.lang.Integer") where + reify jobj = do + klass <- findClass "java/lang/Integer" + method <- getMethodID klass "longValue" "()L" + fromIntegral <$> callLongMethod jobj method [] + + instance Reflect Int ('Class "java.lang.Integer") where + reflect x = new [JInt (fromIntegral x)] + + type instance Interp Double = 'Class "java.lang.Double" + + instance Reify Double ('Class "java.lang.Double") where + reify jobj = do + klass <- findClass "java/lang/Double" + method <- getMethodID klass "doubleValue" "()D" + callDoubleMethod jobj method [] + + instance Reflect Double ('Class "java.lang.Double") where + reflect x = new [JDouble x] + + type instance Interp Text = 'Class "java.lang.String" + + instance Reify Text ('Class "java.lang.String") where + reify jobj = do + sz <- getStringLength jobj + cs <- getStringChars jobj + txt <- Text.fromPtr cs (fromIntegral sz) + releaseStringChars jobj cs + return txt + + instance Reflect Text ('Class "java.lang.String") where + reflect x = + Text.useAsPtr x $ \ptr len -> + newString ptr (fromIntegral len) + + type instance Interp (IOVector Int32) = 'Array ('Prim "int") + + instance Reify (IOVector Int32) ('Array ('Prim "int")) where + reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements) + + instance Reflect (IOVector Int32) ('Array ('Prim "int")) where + reflect = reflectMVector (newIntArray) (setIntArrayRegion) + + type instance Interp (Vector Int32) = 'Array ('Prim "int") + + instance Reify (Vector Int32) ('Array ('Prim "int")) where + reify = Vector.freeze <=< reify + + instance Reflect (Vector Int32) ('Array ('Prim "int")) where + reflect = reflect <=< Vector.thaw + + type instance Interp [a] = 'Array (Interp (Uncurry a)) + + instance Reify a ty => Reify [a] ('Array ty) where + reify jobj = do + n <- getArrayLength jobj + forM [0..n-1] $ \i -> do + x <- getObjectArrayElement jobj i + reify x + + instance Reflect a ty => Reflect [a] ('Array ty) where + reflect xs = do + let n = fromIntegral (length xs) + klass <- findClass "java/lang/Object" + array <- newObjectArray n klass + forM_ (zip [0..n-1] xs) $ \(i, x) -> do + setObjectArrayElement array i =<< reflect x + return (unsafeCast array) + |]