inline-java (empty) → 0.1
raw patch · 8 files changed
+1629/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, distributed-closure, inline-c, singletons, text, thread-local-storage, vector
Files
- LICENSE +30/−0
- README.md +59/−0
- Setup.hs +2/−0
- inline-java.cabal +41/−0
- src/Foreign/JNI.c +353/−0
- src/Foreign/JNI.hs +477/−0
- src/Foreign/JNI/Types.hs +283/−0
- src/Language/Java.hs +384/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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++++Sparkle is maintained by [Tweag I/O](http://tweag.io/).++Have questions? Need help? Tweet at+[@tweagio](http://twitter.com/tweagio).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ inline-java.cabal view
@@ -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
+ src/Foreign/JNI.c view
@@ -0,0 +1,353 @@++#include <jni.h>++#include <errno.h>++#include <stdlib.h>++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); ;+}+
+ src/Foreign/JNI.hs view
@@ -0,0 +1,477 @@+-- | 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.++{-# 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 "<jni.h>"+C.include "<errno.h>"+C.include "<stdlib.h>"++data JavaException = JavaException JThrowable+ deriving (Show, Typeable)++instance Exception JavaException++-- | 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 (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 "<init>" 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)); } |]
+ src/Foreign/JNI/Types.hs view
@@ -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 |])+ ]
+ src/Language/Java.hs view
@@ -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)+ |]