inline-java 0.1 → 0.5
raw patch · 10 files changed
+512/−1532 lines, 10 filesdep +filepathdep +ghc-heap-viewdep +hspecdep ~basedep ~bytestringdep ~singletonsnew-uploader
Dependencies added: filepath, ghc-heap-view, hspec, inline-java, jni, jvm, language-java, monad-loops, process, syb, template-haskell, temporary
Dependency ranges changed: base, bytestring, singletons, text
Files
- README.md +18/−23
- inline-java.cabal +38/−12
- src/Foreign/JNI.c +0/−353
- src/Foreign/JNI.hs +0/−477
- src/Foreign/JNI/Types.hs +0/−283
- src/Language/Java.hs +0/−384
- src/Language/Java/Inline.hs +412/−0
- tests/Language/Java/InlineSpec.hs +35/−0
- tests/Main.hs +8/−0
- tests/Spec.hs +1/−0
README.md view
@@ -1,5 +1,11 @@ # inline-java: Call any JVM function from Haskell +[](https://circleci.com/gh/tweag/inline-java)++**NOTE: you'll need GHC >= 8.0.2 to compile and use this package. Use+`stack --nix --stack-yaml stack-HEAD.yaml build` ahead of a new GHC+release.**+ 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@@ -8,52 +14,41 @@ `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 #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where -import Data.Text (Text)+import Data.Int import Language.Java--newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane"))-instance Coercible JOptionPane ('Class "javax.swing.JOptionPane")+import Language.Java.Inline -main :: IO ()+main :: IO Int32 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+ message <- reflect "Hello World!"+ [java| { javax.swing.JOptionPane.showMessageDialog(null, $message);+ return 0; } |] ```+ ## License Copyright (c) 2015-2016 EURL Tweag. All rights reserved. -Sparkle is free software, and may be redistributed under the terms+inline-java 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/).+inline-java is maintained by [Tweag I/O](http://tweag.io/). Have questions? Need help? Tweet at [@tweagio](http://twitter.com/tweagio).
inline-java.cabal view
@@ -1,41 +1,67 @@ name: inline-java-version: 0.1+version: 0.5 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+maintainer: m@tweag.io copyright: 2015-2016 EURL Tweag. category: FFI, JVM, Java build-type: Simple cabal-version: >=1.10 extra-source-files: README.md+extra-tmp-files:+ src/Foreign/JNI.c 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+ hs-source-dirs: src exposed-modules:- Foreign.JNI- Language.Java- other-modules:- Foreign.JNI.Types+ Language.Java.Inline build-depends:- base >= 4.7 && < 5,+ -- Can't build at all with GHC < 8.0.2.+ base > 4.9.0.0 && < 5, binary >=0.7, bytestring >=0.10, containers >=0.5, distributed-closure >=0.3,+ filepath >= 1,+ ghc-heap-view >= 0.5, inline-c >=0.5,+ jni >= 0.1,+ jvm >= 0.1,+ language-java >= 0.2,+ monad-loops >= 0.4,+ process >= 1.2, singletons >= 2.0,+ syb >= 0.6, text >=1.2,+ template-haskell >= 2.10,+ temporary >= 1.2, thread-local-storage >=0.1, vector >=0.11- default-language: Haskell2010+ default-language: Haskell2010++test-suite spec+ type:+ exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ other-modules:+ Spec+ Language.Java.InlineSpec+ build-depends:+ base,+ bytestring,+ jvm,+ hspec,+ inline-java,+ singletons,+ text+ default-language: Haskell2010+ extra-libraries: pthread
− src/Foreign/JNI.c
@@ -1,353 +0,0 @@--#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
@@ -1,477 +0,0 @@--- | Low-level bindings to the Java Native Interface (JNI).------ Read the--- <https://docs.oracle.com/javase/8/docs/technotes/guides/jni/spec/jniTOC.html JNI spec>--- for authoritative documentation as to what each of the functions in--- this module does. The names of the bindings in this module were chosen to--- match the names of the functions in the JNI spec.------ All bindings in this module access the JNI via a thread-local variable of--- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the--- JVM, it is attached implicitly upon the first call to one of these bindings--- in the current thread.--{-# 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
@@ -1,283 +0,0 @@-{-# 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
@@ -1,384 +0,0 @@--- | High-level helper functions for interacting with Java objects, mapping them--- to Haskell values and vice versa. The 'Reify' and 'Reflect' classes together--- are to Java what "Foreign.Storable" is to C: they provide a means to--- marshall/unmarshall Java objects from/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)- |]
+ src/Language/Java/Inline.hs view
@@ -0,0 +1,412 @@+-- | = Inline Java quasiquotation+--+-- See the+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell-quasi-quotation GHC manual>+-- for an introduction to quasiquotation. The quasiquoter exported in this+-- module allows embedding arbitrary Java expressions and blocks of statements+-- inside Haskell code. You can call any Java method and define arbitrary inline+-- code using Java syntax. No FFI required.+--+-- Here is the same example as in "Language.Java", but with inline Java calls:+--+-- @+-- {-\# LANGUAGE DataKinds \#-}+-- {-\# LANGUAGE QuasiQuotes \#-}+-- module Object where+--+-- import Language.Java as J+-- import Language.Java.Inline+--+-- newtype Object = Object ('J' (''Class' "java.lang.Object"))+-- instance 'Coercible' Object+--+-- clone :: Object -> IO Object+-- clone obj = [java| $obj.clone() |]+--+-- equals :: Object -> Object -> IO Bool+-- equals obj1 obj2 = [java| $obj1.equals($obj2) |]+--+-- ...+-- @++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Java.Inline+ ( java+ ) where++import Control.Monad (forM_, unless)+import Control.Monad.Fix (mfix)+import Control.Monad.Loops (unfoldM)+import qualified Data.ByteString.Char8 as BS+import Data.Generics (everything, mkQ)+import Data.List (intercalate, isPrefixOf, isSuffixOf)+import Data.Maybe (fromJust)+import Data.Singletons (SomeSing(..))+import Data.String (fromString)+import Data.Traversable (forM)+import Foreign.JNI (defineClass)+import qualified Foreign.JNI.String as JNI+import GHC.Exts (Any)+import qualified GHC.HeapView as HeapView+import GHC.StaticPtr+ ( StaticPtr+ , deRefStaticPtr+ , staticPtrKeys+ , unsafeLookupStaticPtr+ )+import Language.Java+import qualified Language.Java.Parser as Java+import qualified Language.Java.Pretty as Java+import qualified Language.Java.Syntax as Java+import Language.Haskell.TH.Quote+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Ppr as TH+import qualified Language.Haskell.TH.Syntax as TH+import Language.Haskell.TH (Q)+import System.FilePath ((</>), (<.>))+import System.IO.Temp (withSystemTempDirectory)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (callProcess)++-- Implementation strategy+--+-- We know we'll need to declare a new wrapper (a Java static method), but we+-- don't know the types of the arguments nor the return type. So we first name+-- this method and generate a Haskell call to it at the quasiquotation site.+-- Then, we register a module finalizer that captures the local scope. At the+-- end of the module, when all type checking is done, our finalizer will be run.+-- By this point the types of all the variables in the local scope that was+-- captured are fully determined. So we can analyze these types to determine+-- what the signature of the wrapper should be, in order to declare it.+--+-- The last step is to ask the Java toolchain to produce .class bytecode from+-- our declarations. We embed this bytecode in the binary, adding a reference to+-- it in the static pointer table (SPT). That way at runtime we can enumerate+-- the bytecode blobs registered in the SPT, and load them into the JVM one by+-- one.++-- | Java code quasiquoter. Example:+--+-- @+-- imports "javax.swing.JOptionPane"+--+-- hello :: IO ()+-- hello = do+-- message <- reflect ("Hello World!" :: Text)+-- [java| JOptionPane.showMessageDialog(null, $message) |]+-- @+--+-- A quasiquote is a snippet of Java code. The code is assumed to be a block+-- (sequence of statements) if the first non whitespace character is a @{@+-- (curly brace) character. Otherwise it's parsed as an expression. Variables+-- with an initial @$@ (dollar) sign are allowed. They have a special meaning:+-- they stand for antiqotation variables (think of them as format specifiers in+-- printf format string). An antiquotation variable @$foo@ is well-scoped if+-- there exists a variable with the name @foo@ in the Haskell context of the+-- quasiquote, whose type is 'Coercible' to a Java primitive or reference type.+java :: QuasiQuoter+java = QuasiQuoter+ { quoteExp = \txt -> blockOrExpQQ txt+ , quotePat = error "Language.Java.Inline: quotePat"+ , quoteType = error "Language.Java.Inline: quoteType"+ , quoteDec = error "Language.Java.Inline: quoteDec"+ }++antis :: Java.Block -> [String]+antis = everything (++) (mkQ [] (\case Java.Name [Java.Ident ('$':av)] -> [av]; _ -> []))++toJavaType :: Sing (a :: JType) -> Java.Type+toJavaType ty = case Java.parser Java.ttype (pretty ty) of+ Left err -> error $ "toJavaType: " ++ show err+ Right x -> x+ where+ pretty :: Sing (a :: JType) -> String+ pretty (SClass sym) = JNI.toChars sym+ pretty (SIface sym) = JNI.toChars sym+ pretty (SPrim sym) = JNI.toChars sym+ pretty (SArray ty1) = pretty ty1 ++ "[]"+ pretty (SGeneric _ty1 _tys) = error "toJavaType(Generic): Unimplemented."+ pretty SVoid = "void"++abstract+ :: Java.Ident+ -> Maybe Java.Type+ -> [(Java.Ident, Java.Type)]+ -> Java.Block+ -> Java.MemberDecl+abstract mname retty vtys block =+ Java.MethodDecl [Java.Public, Java.Static] [] retty mname params [] body+ where+ body = Java.MethodBody (Just block)+ params = [ Java.FormalParam [] ty False (Java.VarId v) | (v, ty) <- vtys ]++-- | Decode a TH 'Type' into a 'JType'. So named because it's morally the+-- inverse of 'Language.Haskell.TH.Syntax.lift'.+unliftJType :: TH.Type -> Q (SomeSing JType)+unliftJType (TH.AppT (TH.PromotedT nm) (TH.LitT (TH.StrTyLit sym)))+ | nm == 'Class = return $ SomeSing $ SClass (fromString sym)+ | nm == 'Iface = return $ SomeSing $ SIface (fromString sym)+ | nm == 'Prim = return $ SomeSing $ SPrim (fromString sym)+unliftJType (TH.AppT (TH.PromotedT nm) ty)+ | nm == 'Array = unliftJType ty >>= \case SomeSing jty -> return $ SomeSing (SArray jty)+unliftJType (TH.AppT (TH.AppT (TH.PromotedT _nm) _ty) _tys) =+ error "unliftJType (Generic): Unimplemented."+unliftJType (TH.AppT (TH.ConT nm) lit@(TH.LitT (TH.StrTyLit _))) =+ unliftJType $ TH.AppT (TH.PromotedT nm) lit+unliftJType (TH.PromotedT nm)+ | nm == 'Void = return $ SomeSing SVoid+unliftJType ty = fail $ "unliftJType: cannot unlift " ++ show (TH.ppr ty)++getValueName :: String -> Q TH.Name+getValueName v =+ TH.lookupValueName v >>= \case+ Nothing -> fail $ "Identifier not in scope: " ++ v+ Just name -> return name++makeCompilationUnit+ :: Java.Name+ -> [Java.ImportDecl]+ -> Java.ClassDecl+ -> Java.CompilationUnit+makeCompilationUnit pkgname imports cls =+ Java.CompilationUnit (Just (Java.PackageDecl pkgname)) imports [Java.ClassTypeDecl cls]++makeClass :: Java.Ident -> [Java.MemberDecl] -> Java.ClassDecl+makeClass cname methods =+ Java.ClassDecl+ []+ cname+ []+ Nothing+ []+ (Java.ClassBody+ (map Java.MemberDecl methods))++emit :: FilePath -> Java.CompilationUnit -> IO ()+emit file cdecl = writeFile file (Java.prettyPrint cdecl)++-- | Private newtype to key the TH state.+data FinalizerState = FinalizerState+ { finalizerCount :: Int+ , wrappers :: [Java.MemberDecl]+ }++initialFinalizerState :: FinalizerState+initialFinalizerState = FinalizerState 0 []++getFinalizerState :: Q FinalizerState+getFinalizerState = TH.getQ >>= \case+ Nothing -> do+ TH.putQ initialFinalizerState+ return initialFinalizerState+ Just st -> return st++setFinalizerState :: FinalizerState -> Q ()+setFinalizerState = TH.putQ++incrementFinalizerCount :: Q ()+incrementFinalizerCount =+ getFinalizerState >>= \FinalizerState{..} ->+ setFinalizerState FinalizerState{finalizerCount = finalizerCount + 1, ..}++decrementFinalizerCount :: Q ()+decrementFinalizerCount =+ getFinalizerState >>= \FinalizerState{..} ->+ setFinalizerState FinalizerState{finalizerCount = max 0 (finalizerCount - 1), ..}++isLastFinalizer :: Q Bool+isLastFinalizer = getFinalizerState >>= \FinalizerState{..} -> return $ finalizerCount == 0++pushWrapper :: Java.MemberDecl -> Q ()+pushWrapper w =+ getFinalizerState >>= \FinalizerState{..} ->+ setFinalizerState FinalizerState{wrappers = w:wrappers, ..}++pushWrapperGen :: Q Java.MemberDecl -> Q ()+pushWrapperGen gen = do+ incrementFinalizerCount+ TH.addModFinalizer $ do+ decrementFinalizerCount+ pushWrapper =<< gen+ isLastFinalizer >>= \case+ True -> do+ FinalizerState{wrappers} <- getFinalizerState+ thismod <- TH.thisModule+ unless (null wrappers) $ do+ embedAsBytecode "io/tweag/inlinejava" (mangle thismod) $+ makeCompilationUnit pkgname [] $+ makeClass (Java.Ident (mangle thismod)) wrappers+ False -> return ()+ where+ pkgname = Java.Name $ map Java.Ident ["io", "tweag", "inlinejava"]++-- | A wrapper for class bytecode.+data DotClass = DotClass+ { className :: JNI.String+ , classBytecode :: BS.ByteString+ }++embedAsBytecode :: String -> String -> Java.CompilationUnit -> Q ()+embedAsBytecode pkg name unit = do+ bcode <- TH.runIO $ do+ withSystemTempDirectory "inlinejava" $ \dir -> do+ let src = dir </> name <.> "java"+ emit src unit+ putStrLn (Java.prettyPrint unit)+ callProcess "javac" [src]+ BS.readFile (dir </> name <.> "class")+ f <- TH.newName "inlinejava__bytecode"+ TH.addTopDecls =<<+ sequence+ [ TH.sigD f [t| StaticPtr DotClass |]+ , TH.valD+ (TH.varP f)+ (TH.normalB+ [| static+ (DotClass (fromString $(TH.lift (pkg ++ "/" ++ name)))+ (BS.pack $(TH.lift (BS.unpack bcode)))) |])+ []+ ]++newtype ClassLoader = ClassLoader (J ('Class "java.lang.ClassLoader"))+instance Coercible ClassLoader ('Class "java.lang.ClassLoader")++-- | Idempotent action that loads all wrappers in every module of the current+-- program into the JVM.+loadJavaWrappers :: IO ()+loadJavaWrappers = doit `seq` return ()+ where+ {-# NOINLINE doit #-}+ doit = unsafePerformIO $ do+ keys <- staticPtrKeys+ loader :: ClassLoader <-+ callStatic (classOf (undefined :: ClassLoader)) "getSystemClassLoader" []+ forM_ keys $ \key -> do+ sptr :: StaticPtr Any <- fromJust <$> unsafeLookupStaticPtr key+ let !x = deRefStaticPtr sptr+ HeapView.getClosureData x >>= \case+ HeapView.ConsClosure{..}+ | "inline-java" `isPrefixOf` pkg+ , intercalate "." [modl, name] == show 'DotClass -> do+ clsPtr <- fromJust <$> unsafeLookupStaticPtr key+ let DotClass clsname bcode = deRefStaticPtr clsPtr+ _ <- defineClass clsname loader bcode+ return ()+ _ -> return ()++mangle :: TH.Module -> String+mangle (TH.Module (TH.PkgName pkgname) (TH.ModName mname)) =+ "Inline__" ++ pkgname ++ "_" ++ map (\case '.' -> '_'; x -> x) mname++data Some = forall ty. Some (IO (J ty))++blockOrExpQQ :: String -> Q TH.Exp+blockOrExpQQ txt@(words -> toks) -- ignore whitespace+ | ["{"] `isPrefixOf` toks+ , ["}"] `isSuffixOf` toks = blockQQ txt+ | otherwise = expQQ txt++expQQ :: String -> Q TH.Exp+expQQ input = blockQQ $ "{ return " ++ input ++ "; }"++blockQQ :: String -> Q TH.Exp+blockQQ input = case Java.parser Java.block input of+ Left err -> fail $ show err+ Right block -> do+ mname <- TH.newName "function"+ pushWrapperGen $ do+ vtys <- forM (antis block) $ \v -> do+ name <- getValueName v+ info <- TH.reify name+ TH.runIO $ print info+ case info of+#if MIN_VERSION_template_haskell(2,11,0)+ TH.VarI _ (TH.AppT (TH.ConT nJ) thty) _+#else+ TH.VarI _ (TH.AppT (TH.ConT nJ) thty) _ _+#endif+ | nJ == ''J -> do+ unliftJType thty >>= \case+ SomeSing ty1 -> return $ (Java.Ident ('$':v), toJavaType ty1)+#if MIN_VERSION_template_haskell(2,11,0)+ TH.VarI _ ty _ -> do+#else+ TH.VarI _ ty _ _ -> do+#endif+ targetty <- TH.newName "a"+ instances <- TH.reifyInstances ''Coercible [ty, TH.VarT targetty]+ jty <- case instances of+ [TH.InstanceD _ _ (TH.AppT (TH.AppT _ _) thty) _] -> unliftJType thty >>= \case+ SomeSing ty1 -> return $ toJavaType ty1+ [] -> fail $ "No Coercible instance for type " ++ show (TH.ppr ty)+ _ ->+ fail $+ "Ambiguous argument type " +++ show (TH.ppr ty) +++ ". Several Coercible instances apply."+ return (Java.Ident ('$':v), jty)+ _ -> fail $ v ++ " not a valid variable name."+ let retty = toJavaType (SClass "java.lang.Object")+ return $ abstract+ (Java.Ident (show mname))+ (Just retty)+ vtys+ block+ -- Return a call to the static method we just generated.+ let args = [ [| coerce $(TH.varE =<< getValueName v) |] | v <- antis block ]+ thismod <- TH.thisModule+ castReturnType+ [| loadJavaWrappers >>+ callStatic+ (sing :: Sing $(TH.litT $ TH.strTyLit ("io.tweag.inlinejava." ++ mangle thismod)))+ (fromString $(TH.stringE (show mname)))+ $(TH.listE args) :: IO (J ('Class "java.lang.Object")) |]+ where+ -- As of GHC 8.0.2, 'addModFinalizer' will only see variables that are+ -- already in scope at the call site, not new variables that are spliced+ -- in. So we can't get at the return type of the call to the wrapper we+ -- just generated. Therefore, we have no choice but to assume all wrappers+ -- always return java.lang.Object. This works, because in Java >= 5 if+ -- what you have is a primitive type but what you're requesting is an+ -- object type, then the value of primitive type gets autoboxed. So now we+ -- have to guess on the Haskell side what autoboxing did. We assume+ -- autoboxing is equivalent to reflecting a value at primitive type.+ --+ -- We have to write part of this programmatically due to a TH limitation,+ -- https://ghc.haskell.org/trac/ghc/ticket/12164. It stands for:+ --+ -- @+ -- [| -- Determine what Java type we'd get if we reflected the result.+ -- -- That's the type we need to reify from.+ -- mfix $ \x -> case Some (reflect x) of+ -- Some (_ :: IO (J ty)) -> do+ -- y <- $funcall+ -- reify (unsafeCast y :: J ty)+ -- |]+ -- @+ castReturnType funcall = do+ ty <- TH.newName "ty"+ [| mfix $ \x ->+ $(TH.caseE+ [| Some (reflect x) |]+ [TH.match+ (TH.conP 'Some [TH.sigP TH.wildP [t| IO (J $(TH.varT ty)) |]])+ (TH.normalB [| do+ y <- $funcall+ reify (unsafeCast y :: J ty) |])+ []]) |]
+ tests/Language/Java/InlineSpec.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Java.InlineSpec where++import Data.Int+import Language.Java.Inline+import Test.Hspec++spec :: Spec+spec = do+ describe "Java quasiquoter" $ do+ it "Evaluates simple expressions" $ do+ [java| 1 + 1 |] `shouldReturn` (2 :: Int32)++ it "Evaluates simple blocks" $ do+ [java| {+ int x = 1;+ int y = 2;+ return x + y;+ } |] `shouldReturn` (3 :: Int32)++ it "Supports antiquotation variables" $ do+ let x = 1 :: Int32+ [java| $x + 1 |] `shouldReturn` (2 :: Int32)++ it "Supports multiple antiquotation variables" $ do+ let foo = 1 :: Int32+ bar = 2 :: Int32+ [java| $foo + $bar |] `shouldReturn` (3 :: Int32)++ it "Supports antiquotation variables in blocks" $ do+ let z = 1 :: Int32+ [java| { return $z + 1; } |] `shouldReturn` (2 :: Int32)
+ tests/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Language.Java (withJVM)+import qualified Spec+import Test.Hspec++main :: IO ()+main = withJVM [] $ hspec Spec.spec
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}