diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,11 @@ # inline-java: Call any JVM function from Haskell +[![Circle CI](https://circleci.com/gh/tweag/inline-java.svg?style=svg)](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 ![Tweag I/O](http://i.imgur.com/0HK8X4y.png) -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). diff --git a/inline-java.cabal b/inline-java.cabal --- a/inline-java.cabal +++ b/inline-java.cabal @@ -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 diff --git a/src/Foreign/JNI.c b/src/Foreign/JNI.c deleted file mode 100644 --- a/src/Foreign/JNI.c +++ /dev/null @@ -1,353 +0,0 @@ - -#include - -#include - -#include - -jthrowable inline_c_Foreign_JNI_0_547acbc2ed14c804f8e5133e90bd68e8a83f9c40(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { -return ( (*env_inline_c_0)->ExceptionOccurred(env_inline_c_1) ); -} - - -void inline_c_Foreign_JNI_1_78814a28f200ba50ae6a800d1c57dc6512afa523(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { - (*env_inline_c_0)->ExceptionDescribe(env_inline_c_1) ; -} - - -void inline_c_Foreign_JNI_2_fa3d0bf0766f27928a66a4776f60d76979f8c97d(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1) { - (*env_inline_c_0)->ExceptionClear(env_inline_c_1) ; -} - - -JNIEnv * inline_c_Foreign_JNI_3_300bcb4b3ee6cf320f3afc172c78066ca8d0d097() { - - jsize num_jvms; - JavaVM *jvm; - /* Assume there's at most one JVM. The current JNI spec (2016) says only - * one JVM per process is supported anyways. */ - JNI_GetCreatedJavaVMs(&jvm, 1, &num_jvms); - JNIEnv *env; - - if(!num_jvms) { - fprintf(stderr, "No JVM has been initialized yet.\n"); - exit(EFAULT); - } - - /* Attach as daemon to match GHC's usual semantics for threads, which are - * daemonic. - */ - (*jvm)->AttachCurrentThreadAsDaemon(jvm, (void**)&env, NULL); - return env; -} - - -JavaVM * inline_c_Foreign_JNI_4_c815bc1d60971caaef72b2be0a16ae8be8624208(int n_inline_c_0, int n_inline_c_1, char ** coptions_inline_c_2, int n_inline_c_3) { - - JavaVM *jvm; - JNIEnv *env; - JavaVMInitArgs vm_args; - JavaVMOption *options = malloc(sizeof(JavaVMOption) * n_inline_c_0); - for(int i = 0; i < n_inline_c_1; i++) - options[0].optionString = coptions_inline_c_2[i]; - vm_args.version = JNI_VERSION_1_6; - vm_args.nOptions = n_inline_c_3; - vm_args.options = options; - vm_args.ignoreUnrecognized = 0; - JNI_CreateJavaVM(&jvm, (void**)&env, &vm_args); - free(options); - return jvm; -} - - -void inline_c_Foreign_JNI_5_b584a6aa1eb7dfd9c78995e2ecba0ce2c820e741(JavaVM * jvm_inline_c_0, JavaVM * jvm_inline_c_1) { - (*jvm_inline_c_0)->DestroyJavaVM(jvm_inline_c_1); -} - - -jclass inline_c_Foreign_JNI_6_8aaec858890db1573fbec87c594caa2d9c2597ac(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, char * name_inline_c_2) { -return ( (*env_inline_c_0)->FindClass(env_inline_c_1, name_inline_c_2) ); -} - - -jobject inline_c_Foreign_JNI_7_db79f2d25dd672f2593a68b078850f23bf59b54d(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID constr_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->NewObjectA(env_inline_c_1, - cls_inline_c_2, - constr_inline_c_3, - cargs_inline_c_4) ); -} - - -jfieldID inline_c_Foreign_JNI_8_47c3da2765e4f1c6c03bb8cdad8bc2d65680370e(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * fieldname_inline_c_3, char * sig_inline_c_4) { -return ( - (*env_inline_c_0)->GetFieldID(env_inline_c_1, - cls_inline_c_2, - fieldname_inline_c_3, - sig_inline_c_4) ); -} - - -jobject inline_c_Foreign_JNI_9_fd81942890ffe8025c7c8e605b29bfa2d631bf64(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jfieldID field_inline_c_3) { -return ( - (*env_inline_c_0)->GetObjectField(env_inline_c_1, - obj_inline_c_2, - field_inline_c_3) ); -} - - -jmethodID inline_c_Foreign_JNI_10_3f3cc5c249c59d38507f1b203b4a80c8a8403f85(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * methodname_inline_c_3, char * sig_inline_c_4) { -return ( - (*env_inline_c_0)->GetMethodID(env_inline_c_1, - cls_inline_c_2, - methodname_inline_c_3, - sig_inline_c_4) ); -} - - -jmethodID inline_c_Foreign_JNI_11_dd0463a591df861dc2b6fe34aa62df3dc045603f(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, char * methodname_inline_c_3, char * sig_inline_c_4) { -return ( - (*env_inline_c_0)->GetStaticMethodID(env_inline_c_1, - cls_inline_c_2, - methodname_inline_c_3, - sig_inline_c_4) ); -} - - -jobject inline_c_Foreign_JNI_12_55bd50e01b2763f523b25ff19116b87a438f4472(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallObjectMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -jboolean inline_c_Foreign_JNI_13_51921259d227ba170aa0d559535ed1fbc1efe9b0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallBooleanMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -jint inline_c_Foreign_JNI_14_d28a2420a47367a1c33fcdd13134997b927047e0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallIntMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -jlong inline_c_Foreign_JNI_15_032fac443ca3e2d4cdd76787a46cab093f442894(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallLongMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -jbyte inline_c_Foreign_JNI_16_8d0dd9482faf1553b421b56cad3ec4f0ca4417b0(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallByteMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -jdouble inline_c_Foreign_JNI_17_97e7fa4f2b0ebaa3ecd3d3eb159d181f5dd74d88(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallDoubleMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -void inline_c_Foreign_JNI_18_882269bf6cfb8dadd0713420cf481299a2626392(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobject obj_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { - - (*env_inline_c_0)->CallVoidMethodA(env_inline_c_1, - obj_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ; -} - - -jobject inline_c_Foreign_JNI_19_8db89b53df84629890dfd632bb1cf065581e5658(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { -return ( - (*env_inline_c_0)->CallStaticObjectMethodA(env_inline_c_1, - cls_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ); -} - - -void inline_c_Foreign_JNI_20_07d8ef24eefeeb4e75fc82280b5661d536563284(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jclass cls_inline_c_2, jmethodID method_inline_c_3, jvalue * cargs_inline_c_4) { - - (*env_inline_c_0)->CallStaticVoidMethodA(env_inline_c_1, - cls_inline_c_2, - method_inline_c_3, - cargs_inline_c_4) ; -} - - -jintArray inline_c_Foreign_JNI_21_fed08588a63cb947275fb36261f23e1b734a77a7(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { -return ( - (*env_inline_c_0)->NewIntArray(env_inline_c_1, - sz_inline_c_2) ); -} - - -jbyteArray inline_c_Foreign_JNI_22_b35c0a12df8861976445a64e0ad8fa9a734b69f2(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { -return ( - (*env_inline_c_0)->NewByteArray(env_inline_c_1, - sz_inline_c_2) ); -} - - -jdoubleArray inline_c_Foreign_JNI_23_fa58b230f44695586d4bf7408ef11a9119d58791(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2) { -return ( - (*env_inline_c_0)->NewDoubleArray(env_inline_c_1, - sz_inline_c_2) ); -} - - -jobjectArray inline_c_Foreign_JNI_24_0b57533e83360b5a6660bf703521b3b6c2fbec66(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jsize sz_inline_c_2, jclass cls_inline_c_3) { -return ( - (*env_inline_c_0)->NewObjectArray(env_inline_c_1, - sz_inline_c_2, - cls_inline_c_3, - NULL) ); -} - - -jstring inline_c_Foreign_JNI_25_d5ed5b314231e7dc3292c2329a2cb4191e262633(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jchar * ptr_inline_c_2, jsize len_inline_c_3) { -return ( - (*env_inline_c_0)->NewString(env_inline_c_1, - ptr_inline_c_2, - len_inline_c_3) ); -} - - -jsize inline_c_Foreign_JNI_26_9be0134c89fa74c4d07a2601d81d89982ce8bdf6(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jarray array_inline_c_2) { -return ( - (*env_inline_c_0)->GetArrayLength(env_inline_c_1, - array_inline_c_2) ); -} - - -jsize inline_c_Foreign_JNI_27_2e55ce4ded52c43b7b69c0c49c4425aef4f8a80b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2) { -return ( - (*env_inline_c_0)->GetStringLength(env_inline_c_1, - jstr_inline_c_2) ); -} - - -jint * inline_c_Foreign_JNI_28_9f5fde34ac136fbf3999d5fd83bf8c6795691309(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2) { -return ( - (*env_inline_c_0)->GetIntArrayElements(env_inline_c_1, - array_inline_c_2, - NULL) ); -} - - -jbyte * inline_c_Foreign_JNI_29_cdab9b47790cf35ecdf9048aa91a969b02a442d4(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2) { -return ( - (*env_inline_c_0)->GetByteArrayElements(env_inline_c_1, - array_inline_c_2, - NULL) ); -} - - -jdouble * inline_c_Foreign_JNI_30_0a74ecc228388d392854113c321eb33afd35fbe9(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jdoubleArray array_inline_c_2) { -return ( - (*env_inline_c_0)->GetDoubleArrayElements(env_inline_c_1, - array_inline_c_2, - NULL) ); -} - - -const jchar * inline_c_Foreign_JNI_31_ac075a3bdcb535575fe36c6f7b5eb3d66ace44a7(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2) { -return ( - (*env_inline_c_0)->GetStringChars(env_inline_c_1, - jstr_inline_c_2, - NULL) ); -} - - -void inline_c_Foreign_JNI_32_cd71790439f2d5820b4dd729a7d949947700110b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jint * buf_inline_c_5) { - - (*env_inline_c_0)->SetIntArrayRegion(env_inline_c_1, - array_inline_c_2, - start_inline_c_3, - len_inline_c_4, - buf_inline_c_5) ; -} - - -void inline_c_Foreign_JNI_33_dc2c381ced7a286daea5604a5b0dc88ea6551f8b(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jbyte * buf_inline_c_5) { - - (*env_inline_c_0)->SetByteArrayRegion(env_inline_c_1, - array_inline_c_2, - start_inline_c_3, - len_inline_c_4, - buf_inline_c_5) ; -} - - -void inline_c_Foreign_JNI_34_183036c6396218e335fec7293ba5fa90e82e8432(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jdoubleArray array_inline_c_2, jsize start_inline_c_3, jsize len_inline_c_4, jdouble * buf_inline_c_5) { - - (*env_inline_c_0)->SetDoubleArrayRegion(env_inline_c_1, - array_inline_c_2, - start_inline_c_3, - len_inline_c_4, - buf_inline_c_5) ; -} - - -void inline_c_Foreign_JNI_35_c7418bff62dd9478672b34cf2bf3839b0e070775(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jintArray array_inline_c_2, jint * xs_inline_c_3) { - - (*env_inline_c_0)->ReleaseIntArrayElements(env_inline_c_1, - array_inline_c_2, - xs_inline_c_3, - JNI_ABORT) ; -} - - -void inline_c_Foreign_JNI_36_cda4e05286c2fbcddb139b19baec3a7cc27dc3a9(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jbyteArray array_inline_c_2, jbyte * xs_inline_c_3) { - - (*env_inline_c_0)->ReleaseByteArrayElements(env_inline_c_1, - array_inline_c_2, - xs_inline_c_3, - JNI_ABORT) ; -} - - -void inline_c_Foreign_JNI_37_7a962d5f8e6114066dca42386535e4a079022eae(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jstring jstr_inline_c_2, jchar * chars_inline_c_3) { - - (*env_inline_c_0)->ReleaseStringChars(env_inline_c_1, - jstr_inline_c_2, - chars_inline_c_3) ; -} - - -jobject inline_c_Foreign_JNI_38_bb66272284cce01d85b6ec31967e1a66eae7e0c5(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jarray array_inline_c_2, jsize i_inline_c_3) { -return ( - (*env_inline_c_0)->GetObjectArrayElement(env_inline_c_1, - array_inline_c_2, - i_inline_c_3) ); -} - - -void inline_c_Foreign_JNI_39_c069b4edd080791f4858d4a7a48b8c42c99c8e4a(JNIEnv * env_inline_c_0, JNIEnv * env_inline_c_1, jobjectArray array_inline_c_2, jsize i_inline_c_3, jobject x_inline_c_4) { - - (*env_inline_c_0)->SetObjectArrayElement(env_inline_c_1, - array_inline_c_2, - i_inline_c_3, - x_inline_c_4); ; -} - diff --git a/src/Foreign/JNI.hs b/src/Foreign/JNI.hs deleted file mode 100644 --- a/src/Foreign/JNI.hs +++ /dev/null @@ -1,477 +0,0 @@ --- | Low-level bindings to the Java Native Interface (JNI). --- --- Read the --- --- for authoritative documentation as to what each of the functions in --- this module does. The names of the bindings in this module were chosen to --- match the names of the functions in the JNI spec. --- --- All bindings in this module access the JNI via a thread-local variable of --- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the --- JVM, it is attached implicitly upon the first call to one of these bindings --- in the current thread. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -module Foreign.JNI - ( module Foreign.JNI.Types - -- * JNI functions - -- ** VM creation - , withJVM - -- ** Query functions - , findClass - , getFieldID - , getObjectField - , getMethodID - , getStaticMethodID - -- ** Method invocation - , callObjectMethod - , callBooleanMethod - , callIntMethod - , callLongMethod - , callByteMethod - , callDoubleMethod - , callVoidMethod - , callStaticObjectMethod - , callStaticVoidMethod - -- ** Object construction - , newObject - , newIntArray - , newDoubleArray - , newByteArray - , newObjectArray - , newString - -- ** Array manipulation - , getArrayLength - , getStringLength - , getIntArrayElements - , getByteArrayElements - , getDoubleArrayElements - , getStringChars - , setIntArrayRegion - , setByteArrayRegion - , setDoubleArrayRegion - , releaseIntArrayElements - , releaseByteArrayElements - , releaseStringChars - , getObjectArrayElement - , setObjectArrayElement - ) where - -import Control.Exception (Exception, bracket, finally, throwIO) -import Control.Monad (unless) -import Data.Coerce -import Data.Int -import Data.IORef (IORef, newIORef, readIORef) -import Data.Word -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Data.TLS.PThread -import Foreign.C (CChar) -import Foreign.JNI.Types -import Foreign.Marshal.Array -import Foreign.Ptr (Ptr, nullPtr) -import qualified Language.C.Inline as C -import qualified Language.C.Inline.Unsafe as CU -import System.IO.Unsafe (unsafePerformIO) - -C.context (C.baseCtx <> C.bsCtx <> jniCtx) - -C.include "" -C.include "" -C.include "" - -data JavaException = JavaException JThrowable - deriving (Show, Typeable) - -instance Exception JavaException - --- | Thrown when @GetArrayElements@ returns a null pointer, --- because it wanted to copy the array contents but couldn't. In this case the --- JVM doesn't throw OutOfMemory according to the JNI spec. -data ArrayCopyFailed = ArrayCopyFailed - deriving (Show, Typeable) - -instance Exception ArrayCopyFailed - --- | Map Java exceptions to Haskell exceptions. -throwIfException :: Ptr JNIEnv -> IO a -> IO a -throwIfException env m = m `finally` do - J excptr <- [CU.exp| jthrowable { (*$(JNIEnv *env))->ExceptionOccurred($(JNIEnv *env)) } |] - unless (excptr == nullPtr) $ do - [CU.exp| void { (*$(JNIEnv *env))->ExceptionDescribe($(JNIEnv *env)) } |] - [CU.exp| void { (*$(JNIEnv *env))->ExceptionClear($(JNIEnv *env)) } |] - throwIO $ JavaException (J excptr) - --- | Check whether a pointer is null. -throwIfNull :: IO (Ptr a) -> IO (Ptr a) -throwIfNull m = do - ptr <- m - if ptr == nullPtr - then throwIO ArrayCopyFailed - else return ptr - --- | A global mutable cell holding the TLS variable, whose content is set once --- for each thread. -envTlsRef :: IORef (TLS (Ptr JNIEnv)) -{-# NOINLINE envTlsRef #-} -envTlsRef = unsafePerformIO $ do - -- It doesn't matter if this computation ends up running twice, say because - -- of lazy blackholing. - !tls <- mkTLS $ [C.block| JNIEnv* { - jsize num_jvms; - JavaVM *jvm; - /* Assume there's at most one JVM. The current JNI spec (2016) says only - * one JVM per process is supported anyways. */ - JNI_GetCreatedJavaVMs(&jvm, 1, &num_jvms); - JNIEnv *env; - - if(!num_jvms) { - fprintf(stderr, "No JVM has been initialized yet.\n"); - exit(EFAULT); - } - - /* Attach as daemon to match GHC's usual semantics for threads, which are - * daemonic. - */ - (*jvm)->AttachCurrentThreadAsDaemon(jvm, (void**)&env, NULL); - return env; } |] - newIORef tls - --- | Run an action against the appropriate 'JNIEnv'. --- --- Each OS thread has its own 'JNIEnv', which this function gives access to. --- --- TODO check whether this call is only safe from a (bound) thread. -withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a -withJNIEnv f = f =<< getTLS =<< readIORef envTlsRef - -useAsCStrings :: [ByteString] -> ([Ptr CChar] -> IO a) -> IO a -useAsCStrings strs m = - foldr (\str k cstrs -> BS.useAsCString str $ \cstr -> k (cstr:cstrs)) m strs [] - --- | Create a new JVM, with the given arguments. /Can only be called once/. Best --- practice: use it to wrap your @main@ function. -withJVM :: [ByteString] -> IO () -> IO () -withJVM options action = - bracket ini fini (const action) - where - ini = do - useAsCStrings options $ \cstrs -> do - withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do - let n = fromIntegral (length cstrs) :: C.CInt - [C.block| JavaVM * { - JavaVM *jvm; - JNIEnv *env; - JavaVMInitArgs vm_args; - JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n)); - for(int i = 0; i < $(int n); i++) - options[0].optionString = $(char **coptions)[i]; - vm_args.version = JNI_VERSION_1_6; - vm_args.nOptions = $(int n); - vm_args.options = options; - vm_args.ignoreUnrecognized = 0; - JNI_CreateJavaVM(&jvm, (void**)&env, &vm_args); - free(options); - return jvm; } |] - fini jvm = [C.block| void { (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm)); } |] - -findClass :: ByteString -> IO JClass -findClass name = withJNIEnv $ \env -> - throwIfException env $ - [C.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $bs-ptr:name) } |] - -newObject :: JClass -> ByteString -> [JValue] -> IO JObject -newObject cls sig args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> do - constr <- getMethodID cls "" sig - [CU.exp| jobject { - (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env), - $(jclass cls), - $(jmethodID constr), - $(jvalue *cargs)) } |] - -getFieldID :: JClass -> ByteString -> ByteString -> IO JFieldID -getFieldID cls fieldname sig = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jfieldID { - (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env), - $(jclass cls), - $bs-ptr:fieldname, - $bs-ptr:sig) } |] - -getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject -getObjectField (coerce -> upcast -> obj) field = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jobject { - (*$(JNIEnv *env))->GetObjectField($(JNIEnv *env), - $(jobject obj), - $(jfieldID field)) } |] - -getMethodID :: JClass -> ByteString -> ByteString -> IO JMethodID -getMethodID cls methodname sig = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jmethodID { - (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env), - $(jclass cls), - $bs-ptr:methodname, - $bs-ptr:sig) } |] - -getStaticMethodID :: JClass -> ByteString -> ByteString -> IO JMethodID -getStaticMethodID cls methodname sig = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jmethodID { - (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env), - $(jclass cls), - $bs-ptr:methodname, - $bs-ptr:sig) } |] - -callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject -callObjectMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jobject { - (*$(JNIEnv *env))->CallObjectMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool -callBooleanMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - fmap (toEnum . fromIntegral) $ withArray args $ \cargs -> - [C.exp| jboolean { - (*$(JNIEnv *env))->CallBooleanMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callIntMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Int32 -callIntMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jint { - (*$(JNIEnv *env))->CallIntMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callLongMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Int64 -callLongMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jlong { - (*$(JNIEnv *env))->CallLongMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callByteMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO CChar -callByteMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jbyte { - (*$(JNIEnv *env))->CallByteMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callDoubleMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Double -callDoubleMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jdouble { - (*$(JNIEnv *env))->CallDoubleMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callVoidMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO () -callVoidMethod (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| void { - (*$(JNIEnv *env))->CallVoidMethodA($(JNIEnv *env), - $(jobject obj), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject -callStaticObjectMethod cls method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| jobject { - (*$(JNIEnv *env))->CallStaticObjectMethodA($(JNIEnv *env), - $(jclass cls), - $(jmethodID method), - $(jvalue *cargs)) } |] - -callStaticVoidMethod :: JClass -> JMethodID -> [JValue] -> IO () -callStaticVoidMethod cls method args = withJNIEnv $ \env -> - throwIfException env $ - withArray args $ \cargs -> - [C.exp| void { - (*$(JNIEnv *env))->CallStaticVoidMethodA($(JNIEnv *env), - $(jclass cls), - $(jmethodID method), - $(jvalue *cargs)) } |] - -newIntArray :: Int32 -> IO JIntArray -newIntArray sz = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jintArray { - (*$(JNIEnv *env))->NewIntArray($(JNIEnv *env), - $(jsize sz)) } |] - -newByteArray :: Int32 -> IO JByteArray -newByteArray sz = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jbyteArray { - (*$(JNIEnv *env))->NewByteArray($(JNIEnv *env), - $(jsize sz)) } |] - -newDoubleArray :: Int32 -> IO JDoubleArray -newDoubleArray sz = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jdoubleArray { - (*$(JNIEnv *env))->NewDoubleArray($(JNIEnv *env), - $(jsize sz)) } |] - -newObjectArray :: Int32 -> JClass -> IO JObjectArray -newObjectArray sz cls = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jobjectArray { - (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env), - $(jsize sz), - $(jclass cls), - NULL) } |] - -newString :: Ptr Word16 -> Int32 -> IO JString -newString ptr len = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| jstring { - (*$(JNIEnv *env))->NewString($(JNIEnv *env), - $(jchar *ptr), - $(jsize len)) } |] - -getArrayLength :: Coercible o (JArray a) => o -> IO Int32 -getArrayLength (coerce -> upcast -> array) = withJNIEnv $ \env -> - [C.exp| jsize { - (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env), - $(jarray array)) } |] - -getStringLength :: JString -> IO Int32 -getStringLength jstr = withJNIEnv $ \env -> - [CU.exp| jsize { - (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env), - $(jstring jstr)) } |] - -getIntArrayElements :: JIntArray -> IO (Ptr Int32) -getIntArrayElements array = withJNIEnv $ \env -> - throwIfNull $ - [CU.exp| jint* { - (*$(JNIEnv *env))->GetIntArrayElements($(JNIEnv *env), - $(jintArray array), - NULL) } |] - -getByteArrayElements :: JByteArray -> IO (Ptr CChar) -getByteArrayElements array = withJNIEnv $ \env -> - throwIfNull $ - [CU.exp| jbyte* { - (*$(JNIEnv *env))->GetByteArrayElements($(JNIEnv *env), - $(jbyteArray array), - NULL) } |] - -getDoubleArrayElements :: JDoubleArray -> IO (Ptr Double) -getDoubleArrayElements array = withJNIEnv $ \env -> - throwIfNull $ - [CU.exp| jdouble* { - (*$(JNIEnv *env))->GetDoubleArrayElements($(JNIEnv *env), - $(jdoubleArray array), - NULL) } |] - -getStringChars :: JString -> IO (Ptr Word16) -getStringChars jstr = withJNIEnv $ \env -> - throwIfNull $ - [CU.exp| const jchar* { - (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env), - $(jstring jstr), - NULL) } |] - -setIntArrayRegion :: JIntArray -> Int32 -> Int32 -> Ptr Int32 -> IO () -setIntArrayRegion array start len buf = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| void { - (*$(JNIEnv *env))->SetIntArrayRegion($(JNIEnv *env), - $(jintArray array), - $(jsize start), - $(jsize len), - $(jint *buf)) } |] - -setByteArrayRegion :: JByteArray -> Int32 -> Int32 -> Ptr CChar -> IO () -setByteArrayRegion array start len buf = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| void { - (*$(JNIEnv *env))->SetByteArrayRegion($(JNIEnv *env), - $(jbyteArray array), - $(jsize start), - $(jsize len), - $(jbyte *buf)) } |] - -setDoubleArrayRegion :: JDoubleArray -> Int32 -> Int32 -> Ptr Double -> IO () -setDoubleArrayRegion array start len buf = withJNIEnv $ \env -> - throwIfException env $ - [CU.exp| void { - (*$(JNIEnv *env))->SetDoubleArrayRegion($(JNIEnv *env), - $(jdoubleArray array), - $(jsize start), - $(jsize len), - $(jdouble *buf)) } |] - -releaseIntArrayElements :: JIntArray -> Ptr Int32 -> IO () -releaseIntArrayElements array xs = withJNIEnv $ \env -> - [CU.exp| void { - (*$(JNIEnv *env))->ReleaseIntArrayElements($(JNIEnv *env), - $(jintArray array), - $(jint *xs), - JNI_ABORT) } |] - -releaseByteArrayElements :: JByteArray -> Ptr CChar -> IO () -releaseByteArrayElements array xs = withJNIEnv $ \env -> - [CU.exp| void { - (*$(JNIEnv *env))->ReleaseByteArrayElements($(JNIEnv *env), - $(jbyteArray array), - $(jbyte *xs), - JNI_ABORT) } |] - -releaseStringChars :: JString -> Ptr Word16 -> IO () -releaseStringChars jstr chars = withJNIEnv $ \env -> - [CU.exp| void { - (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env), - $(jstring jstr), - $(jchar *chars)) } |] - -getObjectArrayElement :: Coercible o (JArray a) => o -> Int32 -> IO (J a) -getObjectArrayElement (coerce -> upcast -> array) i = withJNIEnv $ \env -> unsafeCast <$> - [C.exp| jobject { - (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env), - $(jarray array), - $(jsize i)) } |] - -setObjectArrayElement :: Coercible o (J a) => JObjectArray -> Int32 -> o -> IO () -setObjectArrayElement array i (coerce -> upcast -> x) = withJNIEnv $ \env -> - [C.exp| void { - (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env), - $(jobjectArray array), - $(jsize i), - $(jobject x)); } |] diff --git a/src/Foreign/JNI/Types.hs b/src/Foreign/JNI/Types.hs deleted file mode 100644 --- a/src/Foreign/JNI/Types.hs +++ /dev/null @@ -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 |]) - ] diff --git a/src/Language/Java.hs b/src/Language/Java.hs deleted file mode 100644 --- a/src/Language/Java.hs +++ /dev/null @@ -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) - |] diff --git a/src/Language/Java/Inline.hs b/src/Language/Java/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/Inline.hs @@ -0,0 +1,412 @@ +-- | = Inline Java quasiquotation +-- +-- See the +-- +-- 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) |]) + []]) |] diff --git a/tests/Language/Java/InlineSpec.hs b/tests/Language/Java/InlineSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Java/InlineSpec.hs @@ -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) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Language.Java (withJVM) +import qualified Spec +import Test.Hspec + +main :: IO () +main = withJVM [] $ hspec Spec.spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}