diff --git a/jvm.cabal b/jvm.cabal --- a/jvm.cabal +++ b/jvm.cabal @@ -1,5 +1,5 @@ name: jvm -version: 0.2.1 +version: 0.2.2 synopsis: Call JVM methods from Haskell. description: Please see README.md. homepage: http://github.com/tweag/inline-java/tree/master/jvm#readme @@ -22,6 +22,7 @@ hs-source-dirs: src exposed-modules: Language.Java + Language.Java.TH build-depends: base >= 4.7 && < 5, bytestring >=0.10, @@ -29,6 +30,7 @@ distributed-closure >=0.3, jni >= 0.3.0, singletons >= 2.0, + template-haskell >= 2.10, text >=1.2, vector >=0.11 default-language: Haskell2010 diff --git a/src/Language/Java.hs b/src/Language/Java.hs --- a/src/Language/Java.hs +++ b/src/Language/Java.hs @@ -55,7 +55,6 @@ , call , callStatic , jvalue - , CoercionFailure(..) , Coercible(..) , Reify(..) , Reflect(..) @@ -67,13 +66,11 @@ import Control.Distributed.Closure import Control.Distributed.Closure.TH -import Control.Exception (Exception, throw) import Control.Monad import Data.Char (chr, ord) import qualified Data.Choice as Choice import qualified Data.Coerce as Coerce import Data.Int -import Data.Typeable (Typeable, TypeRep, typeOf) import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -82,16 +79,15 @@ import Data.String (fromString) import qualified Data.Text.Foreign as Text import Data.Text (Text) -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) +#if ! __GLASGOW_HASKELL__ == 800 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 (Ptr, Storable, withForeignPtr) -import Foreign.Concurrent (newForeignPtr) +import Foreign (FunPtr, Ptr, Storable, newForeignPtr, withForeignPtr) #endif import Foreign.C (CChar) -import Foreign.JNI hiding (throw) +import Foreign.JNI import Foreign.JNI.Types import qualified Foreign.JNI.String as JNI import GHC.TypeLits (KnownSymbol, Symbol) @@ -128,58 +124,42 @@ -- | The identity instance. instance SingI ty => Coercible (J ty) ty --- | A JNI call may cause a (Java) exception to be raised. This module raises it --- as a Haskell exception wrapping the Java exception. -data CoercionFailure = CoercionFailure - { coercionActual :: JValue - , coercionExpected :: TypeRep - } - -instance Exception CoercionFailure - -instance Show CoercionFailure where - show (CoercionFailure actual expected) = - "Can't coerce " ++ show actual ++ " to " ++ show expected ++ "." - -withTypeRep :: Typeable a => (TypeRep -> a) -> a -withTypeRep f = let x = f (typeOf x) in x - instance Coercible Bool ('Prim "boolean") where coerce x = JBoolean (fromIntegral (fromEnum x)) unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x) - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible CChar ('Prim "byte") where coerce = JByte unsafeUncoerce (JByte x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + 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 val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Word16 ('Prim "char") where coerce = JChar unsafeUncoerce (JChar x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Int16 ('Prim "short") where coerce = JShort unsafeUncoerce (JShort x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Int32 ('Prim "int") where coerce = JInt unsafeUncoerce (JInt x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Int64 ('Prim "long") where coerce = JLong unsafeUncoerce (JLong x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Float ('Prim "float") where coerce = JFloat unsafeUncoerce (JFloat x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible Double ('Prim "double") where coerce = JDouble unsafeUncoerce (JDouble x) = x - unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) + unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." instance Coercible () 'Void where coerce = error "Void value undefined." unsafeUncoerce _ = () @@ -341,7 +321,11 @@ => Reflect a ty where reflect :: a -> IO (J ty) -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) +#if ! __GLASGOW_HASKELL__ == 800 +foreign import ccall "wrapper" wrapFinalizer + :: (Ptr a -> IO ()) + -> IO (FunPtr (Ptr a -> IO ())) + reifyMVector :: Storable a => (JArray ty -> IO (Ptr a)) @@ -351,7 +335,8 @@ reifyMVector mk finalize jobj = do n <- getArrayLength jobj ptr <- mk jobj - fptr <- newForeignPtr ptr (finalize jobj ptr) + ffinalize <- wrapFinalizer (finalize jobj) + fptr <- newForeignPtr ffinalize ptr return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) reflectMVector @@ -502,7 +487,7 @@ -- Instances can't be compiled on GHC 8.0.1 due to -- https://ghc.haskell.org/trac/ghc/ticket/12082. -#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) +#if ! __GLASGOW_HASKELL__ == 800 type instance Interp (IOVector Int32) = 'Array ('Prim "int") instance Reify (IOVector Int32) ('Array ('Prim "int")) where diff --git a/src/Language/Java/TH.hs b/src/Language/Java/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/TH.hs @@ -0,0 +1,46 @@ +-- | Optional code macros for convenience. + +{-# LANGUAGE TemplateHaskell #-} + +module Language.Java.TH (makeConversions) where + +import Control.Distributed.Closure.TH (withStatic) +import qualified Language.Haskell.TH as TH +import Language.Java + +-- | Define instances of the three conversion classes, 'Coercible', 'Reify' and +-- 'Reflect' for the given datatype. Example usage: +-- +-- @ +-- import qualified Language.Java.TH as Java +-- +-- newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) +-- Java.makeConversions ''JOptionPane +-- @ +-- +-- This is equivalent to: +-- +-- @ +-- newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) +-- instance Coercible JOptionPane ('Class "javax.swing.JOptionPane") +-- instance Reify JOptionPane ('Class "javax.swing.JOptionPane") +-- instance Reflect JOptionPane ('Class "javax.swing.JOptionPane") +-- @ +makeConversions :: TH.Name -> TH.Q [TH.Dec] +makeConversions x = do + info <- TH.reify x + let ty_x = return (TH.ConT x) + ty_cls = case info of + TH.TyConI (TH.DataD [] _ _ _ [cstr] _) -> case cstr of + TH.NormalC _ [(_, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty + TH.RecC _ [(_, _, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty + _ -> notsupported + _ -> notsupported + withStatic [d| + instance Coercible $ty_x $ty_cls + instance Reify $ty_x $ty_cls + instance Reflect $ty_x $ty_cls + |] + where + notsupported = fail + "makeConversions failed. Only newtype wrappers of (J ty) are supported."