{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Language.Java.Unsafe
( module Foreign.JNI.Types
, withJVM
, classOf
, getClass
, setGetClassFunction
, new
, newArray
, toArray
, call
, callStatic
, getStaticField
, VariadicIO
, push
, pushWithSizeHint
, Pop(..)
, pop
, popWithObject
, popWithValue
, withLocalRef
, CoercionFailure(..)
, Coercible(..)
, jvalue
, jobject
, Interpretation(..)
, Reify(..)
, Reflect(..)
, sing
) where
import Control.Distributed.Closure.TH
import Control.Exception (Exception, throw, finally)
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask, bracket, onException)
import Control.Monad.IO.Class
import Data.Char (chr, ord)
import qualified Data.Choice as Choice
import qualified Data.Coerce as Coerce
import Data.Constraint (Dict(..))
import Data.Int
import Data.Proxy (Proxy(..))
import Data.Typeable (Typeable, TypeRep, typeOf)
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Kind (Type)
import Data.Singletons (SingI(..), SomeSing(..))
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 (Ptr, Storable, withForeignPtr)
import Foreign.Concurrent (newForeignPtr)
import Foreign.C (CChar)
import Foreign.JNI hiding (throw)
import Foreign.JNI.Types
import qualified Foreign.JNI.String as JNI
import GHC.TypeLits (KnownSymbol, TypeError, symbolVal)
import qualified GHC.TypeLits as TypeError (ErrorMessage(..))
import Language.Java.Internal
import System.IO.Unsafe (unsafeDupablePerformIO)
data Pop a where
PopValue :: a -> Pop a
PopObject
:: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty)
=> a
-> Pop a
push :: (MonadCatch m, MonadIO m) => m (Pop a) -> m a
push :: m (Pop a) -> m a
push = Int32 -> m (Pop a) -> m a
forall a (m :: * -> *).
(MonadCatch m, MonadIO m) =>
Int32 -> m (Pop a) -> m a
pushWithSizeHint Int32
4
pushWithSizeHint :: forall a m. (MonadCatch m, MonadIO m) => Int32 -> m (Pop a) -> m a
pushWithSizeHint :: Int32 -> m (Pop a) -> m a
pushWithSizeHint Int32
capacity m (Pop a)
m = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int32 -> IO ()
pushLocalFrame Int32
capacity
m (Pop a)
m m (Pop a) -> m (J Any) -> m (Pop a)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` m (J Any)
forall (a :: JType). m (J a)
handler m (Pop a) -> (Pop a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
PopValue a
x -> do
J Any
_ <- IO (J Any) -> m (J Any)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (J Any) -> m (J Any)) -> IO (J Any) -> m (J Any)
forall a b. (a -> b) -> a -> b
$ J Any -> IO (J Any)
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
popLocalFrame J Any
forall (a :: JType). J a
jnull
a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
PopObject a
x -> do
IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ J ty -> a
Coerce.coerce (J ty -> a) -> IO (J ty) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> J ty -> IO (J ty)
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
popLocalFrame (a -> J ty
forall (ty :: JType) a.
(ty ~ Ty a, Coercible a, IsReferenceType ty) =>
a -> J ty
jobject a
x)
where
handler :: m (J a)
handler = IO (J a) -> m (J a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (J a) -> m (J a)) -> IO (J a) -> m (J a)
forall a b. (a -> b) -> a -> b
$ J a -> IO (J a)
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
popLocalFrame J a
forall (a :: JType). J a
jnull
pop :: Monad m => m (Pop ())
pop :: m (Pop ())
pop = Pop () -> m (Pop ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Pop ()
forall a. a -> Pop a
PopValue ())
popWithObject
:: (ty ~ Ty a, Coercible a, Coerce.Coercible a (J ty), IsReferenceType ty, Monad m)
=> a
-> m (Pop a)
popWithObject :: a -> m (Pop a)
popWithObject a
x = Pop a -> m (Pop a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Pop a
forall (ty :: JType) a.
(ty ~ Ty a, Coercible a, Coercible a (J ty), IsReferenceType ty) =>
a -> Pop a
PopObject a
x)
popWithValue :: Monad m => a -> m (Pop a)
popWithValue :: a -> m (Pop a)
popWithValue a
x = Pop a -> m (Pop a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Pop a
forall a. a -> Pop a
PopValue a
x)
withLocalRef
:: (MonadMask m, MonadIO m, Coerce.Coercible o (J ty))
=> m o -> (o -> m a) -> m a
withLocalRef :: m o -> (o -> m a) -> m a
withLocalRef m o
m = m o -> (o -> m ()) -> (o -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m o
m (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (o -> IO ()) -> o -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> IO ()
forall o (ty :: JType). Coercible o (J ty) => o -> IO ()
deleteLocalRef)
class SingI (Ty a) => Coercible a where
type Ty a :: JType
coerce :: a -> JValue
unsafeUncoerce :: JValue -> a
default coerce
:: Coerce.Coercible a (J (Ty a))
=> a
-> JValue
coerce a
x = J (Ty a) -> JValue
forall (a :: JType). SingI a => J a -> JValue
JObject (a -> J (Ty a)
Coerce.coerce a
x :: J (Ty a))
default unsafeUncoerce
:: Coerce.Coercible (J (Ty a)) a
=> JValue
-> a
unsafeUncoerce (JObject J a
obj) = J (Ty a) -> a
Coerce.coerce (J a -> J (Ty a)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast J a
obj :: J (Ty a))
unsafeUncoerce JValue
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot unsafeUncoerce: object expected but value of primitive type found."
instance SingI ty => Coercible (J ty) where
type Ty (J ty) = ty
data CoercionFailure = CoercionFailure
{ CoercionFailure -> JValue
coercionActual :: JValue
, CoercionFailure -> TypeRep
coercionExpected :: TypeRep
}
instance Exception CoercionFailure
instance Show CoercionFailure where
show :: CoercionFailure -> [Char]
show (CoercionFailure JValue
actual TypeRep
expected) =
[Char]
"Can't coerce " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JValue -> [Char]
forall a. Show a => a -> [Char]
show JValue
actual [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show TypeRep
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
withTypeRep :: Typeable a => (TypeRep -> a) -> a
withTypeRep :: (TypeRep -> a) -> a
withTypeRep TypeRep -> a
f = let x :: a
x = TypeRep -> a
f (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x) in a
x
instance Coercible Bool where
type Ty Bool = 'Prim "boolean"
coerce :: Bool -> JValue
coerce Bool
x = Word8 -> JValue
JBoolean (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
x))
unsafeUncoerce :: JValue -> Bool
unsafeUncoerce (JBoolean Word8
x) = Int -> Bool
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)
unsafeUncoerce JValue
val = (TypeRep -> Bool) -> Bool
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Bool
forall a e. Exception e => e -> a
throw (CoercionFailure -> Bool)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible CChar where
type Ty CChar = 'Prim "byte"
coerce :: CChar -> JValue
coerce = CChar -> JValue
JByte
unsafeUncoerce :: JValue -> CChar
unsafeUncoerce (JByte CChar
x) = CChar
x
unsafeUncoerce JValue
val = (TypeRep -> CChar) -> CChar
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> CChar
forall a e. Exception e => e -> a
throw (CoercionFailure -> CChar)
-> (TypeRep -> CoercionFailure) -> TypeRep -> CChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Char where
type Ty Char = 'Prim "char"
coerce :: Char -> JValue
coerce Char
x = Word16 -> JValue
JChar (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
x))
unsafeUncoerce :: JValue -> Char
unsafeUncoerce (JChar Word16
x) = Int -> Char
chr (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x)
unsafeUncoerce JValue
val = (TypeRep -> Char) -> Char
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Char
forall a e. Exception e => e -> a
throw (CoercionFailure -> Char)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Word16 where
type Ty Word16 = 'Prim "char"
coerce :: Word16 -> JValue
coerce = Word16 -> JValue
JChar
unsafeUncoerce :: JValue -> Word16
unsafeUncoerce (JChar Word16
x) = Word16
x
unsafeUncoerce JValue
val = (TypeRep -> Word16) -> Word16
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Word16
forall a e. Exception e => e -> a
throw (CoercionFailure -> Word16)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Int16 where
type Ty Int16 = 'Prim "short"
coerce :: Int16 -> JValue
coerce = Int16 -> JValue
JShort
unsafeUncoerce :: JValue -> Int16
unsafeUncoerce (JShort Int16
x) = Int16
x
unsafeUncoerce JValue
val = (TypeRep -> Int16) -> Int16
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Int16
forall a e. Exception e => e -> a
throw (CoercionFailure -> Int16)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Int32 where
type Ty Int32 = 'Prim "int"
coerce :: Int32 -> JValue
coerce = Int32 -> JValue
JInt
unsafeUncoerce :: JValue -> Int32
unsafeUncoerce (JInt Int32
x) = Int32
x
unsafeUncoerce JValue
val = (TypeRep -> Int32) -> Int32
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Int32
forall a e. Exception e => e -> a
throw (CoercionFailure -> Int32)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Int64 where
type Ty Int64 = 'Prim "long"
coerce :: Int64 -> JValue
coerce = Int64 -> JValue
JLong
unsafeUncoerce :: JValue -> Int64
unsafeUncoerce (JLong Int64
x) = Int64
x
unsafeUncoerce JValue
val = (TypeRep -> Int64) -> Int64
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Int64
forall a e. Exception e => e -> a
throw (CoercionFailure -> Int64)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Float where
type Ty Float = 'Prim "float"
coerce :: Float -> JValue
coerce = Float -> JValue
JFloat
unsafeUncoerce :: JValue -> Float
unsafeUncoerce (JFloat Float
x) = Float
x
unsafeUncoerce JValue
val = (TypeRep -> Float) -> Float
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Float
forall a e. Exception e => e -> a
throw (CoercionFailure -> Float)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible Double where
type Ty Double = 'Prim "double"
coerce :: Double -> JValue
coerce = Double -> JValue
JDouble
unsafeUncoerce :: JValue -> Double
unsafeUncoerce (JDouble Double
x) = Double
x
unsafeUncoerce JValue
val = (TypeRep -> Double) -> Double
forall a. Typeable a => (TypeRep -> a) -> a
withTypeRep (CoercionFailure -> Double
forall a e. Exception e => e -> a
throw (CoercionFailure -> Double)
-> (TypeRep -> CoercionFailure) -> TypeRep -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> TypeRep -> CoercionFailure
CoercionFailure JValue
val)
instance Coercible () where
type Ty () = 'Void
coerce :: () -> JValue
coerce = [Char] -> () -> JValue
forall a. HasCallStack => [Char] -> a
error [Char]
"Void value undefined."
unsafeUncoerce :: JValue -> ()
unsafeUncoerce JValue
_ = ()
instance Coercible (Choice.Choice a) where
type Ty (Choice.Choice a) = 'Prim "boolean"
coerce :: Choice a -> JValue
coerce = Bool -> JValue
forall a. Coercible a => a -> JValue
coerce (Bool -> JValue) -> (Choice a -> Bool) -> Choice a -> JValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Choice a -> Bool
forall (a :: Symbol). Choice a -> Bool
Choice.toBool
unsafeUncoerce :: JValue -> Choice a
unsafeUncoerce = Bool -> Choice a
forall (a :: Symbol). Bool -> Choice a
Choice.fromBool (Bool -> Choice a) -> (JValue -> Bool) -> JValue -> Choice a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JValue -> Bool
forall a. Coercible a => JValue -> a
unsafeUncoerce
jvalue :: (ty ~ Ty a, Coercible a) => a -> JValue
jvalue :: a -> JValue
jvalue = a -> JValue
forall a. Coercible a => a -> JValue
coerce
jobject :: (ty ~ Ty a, Coercible a, IsReferenceType ty) => a -> J ty
jobject :: a -> J ty
jobject a
x
| JObject J a
jobj <- a -> JValue
forall a. Coercible a => a -> JValue
coerce a
x = J a -> J ty
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast J a
jobj
| Bool
otherwise = [Char] -> J ty
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"
classOf
:: forall a sym. (Ty a ~ 'Class sym, Coercible a, KnownSymbol sym)
=> a
-> JNI.String
classOf :: a -> String
classOf a
x = [Char] -> String
JNI.fromChars (Proxy sym -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy sym
forall k (t :: k). Proxy t
Proxy :: Proxy sym)) String -> JValue -> String
forall a b. a -> b -> a
`const` a -> JValue
forall a. Coercible a => a -> JValue
coerce a
x
class VariadicIO_ f where
sings :: Proxy f -> [SomeSing JType]
apply :: ([JValue] -> IO (ReturnTypeIO f)) -> f
type family ReturnTypeIO f :: Data.Kind.Type
type VariadicIO f b = (ReturnTypeIO f ~ b, VariadicIO_ f)
type instance ReturnTypeIO (IO a) = a
instance VariadicIO_ (IO a) where
sings :: Proxy (IO a) -> [SomeSing JType]
sings Proxy (IO a)
_ = []
apply :: ([JValue] -> IO (ReturnTypeIO (IO a))) -> IO a
apply [JValue] -> IO (ReturnTypeIO (IO a))
f = [JValue] -> IO (ReturnTypeIO (IO a))
f []
type instance ReturnTypeIO (a -> f) = ReturnTypeIO f
instance (Coercible a, VariadicIO_ f) => VariadicIO_ (a -> f) where
sings :: Proxy (a -> f) -> [SomeSing JType]
sings Proxy (a -> f)
_ = Sing (Ty a) -> SomeSing JType
forall k (a :: k). Sing a -> SomeSing k
SomeSing (SingI (Ty a) => Sing (Ty a)
forall k (a :: k). SingI a => Sing a
sing @(Ty a)) SomeSing JType -> [SomeSing JType] -> [SomeSing JType]
forall a. a -> [a] -> [a]
: Proxy f -> [SomeSing JType]
forall f. VariadicIO_ f => Proxy f -> [SomeSing JType]
sings @f Proxy f
forall k (t :: k). Proxy t
Proxy
apply :: ([JValue] -> IO (ReturnTypeIO (a -> f))) -> a -> f
apply [JValue] -> IO (ReturnTypeIO (a -> f))
f a
x = ([JValue] -> IO (ReturnTypeIO f)) -> f
forall f. VariadicIO_ f => ([JValue] -> IO (ReturnTypeIO f)) -> f
apply (\[JValue]
xs -> [JValue] -> IO (ReturnTypeIO (a -> f))
f (a -> JValue
forall a. Coercible a => a -> JValue
coerce a
x JValue -> [JValue] -> [JValue]
forall a. a -> [a] -> [a]
: [JValue]
xs))
instance
{-# OVERLAPPABLE #-}
TypeError (TypeError.Text "Expected: a₁ -> ... -> aₙ -> IO b" TypeError.:$$:
TypeError.Text "Actual: " TypeError.:<>: TypeError.ShowType x) =>
VariadicIO_ x where
sings :: Proxy x -> [SomeSing JType]
sings = Proxy x -> [SomeSing JType]
forall a. HasCallStack => a
undefined
apply :: ([JValue] -> IO (ReturnTypeIO x)) -> x
apply = ([JValue] -> IO (ReturnTypeIO x)) -> x
forall a. HasCallStack => a
undefined
new
:: forall a f sym.
( Ty a ~ 'Class sym
, Coerce.Coercible a (J ('Class sym))
, Coercible a
, VariadicIO f a
) => f
{-# INLINE new #-}
new :: f
new = ([JValue] -> IO (ReturnTypeIO f)) -> f
forall f. VariadicIO_ f => ([JValue] -> IO (ReturnTypeIO f)) -> f
apply (([JValue] -> IO (ReturnTypeIO f)) -> f)
-> ([JValue] -> IO (ReturnTypeIO f)) -> f
forall a b. (a -> b) -> a -> b
$ \[JValue]
args -> J ('Class sym) -> a
Coerce.coerce (J ('Class sym) -> a) -> IO (J ('Class sym)) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SomeSing JType] -> [JValue] -> IO (J ('Class sym))
forall (sym :: Symbol) (ty :: JType).
(ty ~ 'Class sym, SingI ty) =>
[SomeSing JType] -> [JValue] -> IO (J ty)
newJ @sym (Proxy f -> [SomeSing JType]
forall f. VariadicIO_ f => Proxy f -> [SomeSing JType]
sings @f Proxy f
forall k (t :: k). Proxy t
Proxy) [JValue]
args
newArray :: forall ty. SingI ty => Int32 -> IO (J ('Array ty))
{-# INLINE newArray #-}
newArray :: Int32 -> IO (J ('Array ty))
newArray Int32
sz = do
let tysing :: Sing ty
tysing = SingI ty => Sing ty
forall k (a :: k). SingI a => Sing a
sing @ty
case Sing ty
tysing of
SPrim "boolean" -> J ('Array ('Prim "boolean")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "boolean")) -> J ('Array ty))
-> IO (J ('Array ('Prim "boolean"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "boolean")))
newBooleanArray Int32
sz
SPrim "byte" -> J ('Array ('Prim "byte")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "byte")) -> J ('Array ty))
-> IO (J ('Array ('Prim "byte"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "byte")))
newByteArray Int32
sz
SPrim "char" -> J ('Array ('Prim "char")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "char")) -> J ('Array ty))
-> IO (J ('Array ('Prim "char"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "char")))
newCharArray Int32
sz
SPrim "short" -> J ('Array ('Prim "short")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "short")) -> J ('Array ty))
-> IO (J ('Array ('Prim "short"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "short")))
newShortArray Int32
sz
SPrim "int" -> J ('Array ('Prim "int")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "int")) -> J ('Array ty))
-> IO (J ('Array ('Prim "int"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "int")))
newIntArray Int32
sz
SPrim "long" -> J ('Array ('Prim "long")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "long")) -> J ('Array ty))
-> IO (J ('Array ('Prim "long"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "long")))
newLongArray Int32
sz
SPrim "float" -> J ('Array ('Prim "float")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "float")) -> J ('Array ty))
-> IO (J ('Array ('Prim "float"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "float")))
newFloatArray Int32
sz
SPrim "double" -> J ('Array ('Prim "double")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Prim "double")) -> J ('Array ty))
-> IO (J ('Array ('Prim "double"))) -> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO (J ('Array ('Prim "double")))
newDoubleArray Int32
sz
Sing ty
SVoid -> [Char] -> IO (J ('Array ty))
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"newArray of void"
Sing ty
_ -> case Sing ty -> Maybe (Dict (IsReferenceType ty))
forall (ty :: JType). Sing ty -> Maybe (Dict (IsReferenceType ty))
singToIsReferenceType Sing ty
tysing of
Maybe (Dict (IsReferenceType ty))
Nothing -> [Char] -> IO (J ('Array ty))
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO (J ('Array ty))) -> [Char] -> IO (J ('Array ty))
forall a b. (a -> b) -> a -> b
$ [Char]
"newArray of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SJType ty -> [Char]
forall a. Show a => a -> [Char]
show Sing ty
SJType ty
tysing
Just Dict (IsReferenceType ty)
Dict -> do
let klass :: JClass
klass = IO JClass -> JClass
forall a. IO a -> a
unsafeDupablePerformIO (IO JClass -> JClass) -> IO JClass -> JClass
forall a b. (a -> b) -> a -> b
$ do
JClass
lk <- Sing ty -> IO JClass
forall (ty :: JType). IsReferenceType ty => Sing ty -> IO JClass
getClass Sing ty
tysing
JClass
gk <- JClass -> IO JClass
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
newGlobalRef JClass
lk
JClass -> IO ()
forall o (ty :: JType). Coercible o (J ty) => o -> IO ()
deleteLocalRef JClass
lk
JClass -> IO JClass
forall (m :: * -> *) a. Monad m => a -> m a
return JClass
gk
J ('Array ('Class "java.lang.Object")) -> J ('Array ty)
forall (a :: JType) (b :: JType). J a -> J b
unsafeCast (J ('Array ('Class "java.lang.Object")) -> J ('Array ty))
-> IO (J ('Array ('Class "java.lang.Object")))
-> IO (J ('Array ty))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> JClass -> IO (J ('Array ('Class "java.lang.Object")))
newObjectArray Int32
sz JClass
klass
toArray
:: forall ty. (SingI ty, IsReferenceType ty)
=> [J ty]
-> IO (J ('Array ty))
toArray :: [J ty] -> IO (J ('Array ty))
toArray [J ty]
xs = do
let n :: Int32
n = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([J ty] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [J ty]
xs)
J ('Array ty)
jxs <- Int32 -> IO (J ('Array ty))
forall (ty :: JType). SingI ty => Int32 -> IO (J ('Array ty))
newArray Int32
n
(Int32 -> J ty -> IO ()) -> [Int32] -> [J ty] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (J ('Array ty) -> Int32 -> J ty -> IO ()
forall (a :: JType) o.
(IsReferenceType a, Coercible o (J a)) =>
JArray a -> Int32 -> o -> IO ()
setObjectArrayElement J ('Array ty)
jxs) [Int32
0 .. Int32
n Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1] [J ty]
xs
J ('Array ty) -> IO (J ('Array ty))
forall (m :: * -> *) a. Monad m => a -> m a
return J ('Array ty)
jxs
call
:: forall a b ty f.
( VariadicIO f b
, ty ~ Ty a
, IsReferenceType ty
, Coercible a
, Coercible b
, Coerce.Coercible a (J ty)
)
=> a
-> JNI.String
-> f
call :: a -> String -> f
call a
obj String
mname = ([JValue] -> IO (ReturnTypeIO f)) -> f
forall f. VariadicIO_ f => ([JValue] -> IO (ReturnTypeIO f)) -> f
apply (([JValue] -> IO (ReturnTypeIO f)) -> f)
-> ([JValue] -> IO (ReturnTypeIO f)) -> f
forall a b. (a -> b) -> a -> b
$ \[JValue]
args ->
JValue -> b
forall a. Coercible a => JValue -> a
unsafeUncoerce (JValue -> b) -> IO JValue -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Sing (Ty b)
-> J ty -> String -> [SomeSing JType] -> [JValue] -> IO JValue
forall (ty1 :: JType) (k :: JType).
(IsReferenceType ty1, SingI ty1) =>
Sing k
-> J ty1 -> String -> [SomeSing JType] -> [JValue] -> IO JValue
callToJValue
(SingI (Ty b) => Sing (Ty b)
forall k (a :: k). SingI a => Sing a
sing @(Ty b))
(a -> J ty
Coerce.coerce a
obj :: J ty)
String
mname
(Proxy f -> [SomeSing JType]
forall f. VariadicIO_ f => Proxy f -> [SomeSing JType]
sings @f Proxy f
forall k (t :: k). Proxy t
Proxy)
[JValue]
args
callStatic
:: forall a ty f.
(ty ~ Ty a, Coercible a, VariadicIO f a)
=> JNI.String
-> JNI.String
-> f
{-# INLINE callStatic #-}
callStatic :: String -> String -> f
callStatic String
cname String
mname = ([JValue] -> IO (ReturnTypeIO f)) -> f
forall f. VariadicIO_ f => ([JValue] -> IO (ReturnTypeIO f)) -> f
apply (([JValue] -> IO (ReturnTypeIO f)) -> f)
-> ([JValue] -> IO (ReturnTypeIO f)) -> f
forall a b. (a -> b) -> a -> b
$ \[JValue]
args ->
JValue -> a
forall a. Coercible a => JValue -> a
unsafeUncoerce (JValue -> a) -> IO JValue -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Sing ty
-> String -> String -> [SomeSing JType] -> [JValue] -> IO JValue
forall (k :: JType).
Sing k
-> String -> String -> [SomeSing JType] -> [JValue] -> IO JValue
callStaticToJValue (SingI ty => Sing ty
forall k (a :: k). SingI a => Sing a
sing @ty) String
cname String
mname (Proxy f -> [SomeSing JType]
forall f. VariadicIO_ f => Proxy f -> [SomeSing JType]
sings @f Proxy f
forall k (t :: k). Proxy t
Proxy) [JValue]
args
getStaticField
:: forall a ty. (ty ~ Ty a, Coercible a)
=> JNI.String
-> JNI.String
-> IO a
{-# INLINE getStaticField #-}
getStaticField :: String -> String -> IO a
getStaticField String
cname String
fname =
JValue -> a
forall a. Coercible a => JValue -> a
unsafeUncoerce (JValue -> a) -> IO JValue -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing ty -> String -> String -> IO JValue
forall (ty :: JType). Sing ty -> String -> String -> IO JValue
getStaticFieldAsJValue (SingI ty => Sing ty
forall k (a :: k). SingI a => Sing a
sing @ty) String
cname String
fname
class (SingI (Interp a), IsReferenceType (Interp a)) => Interpretation (a :: k) where
type Interp a :: JType
class Interpretation a => Reify a where
reify :: J (Interp a) -> IO a
default reify :: (Coercible a, Interp a ~ Ty a) => J (Interp a) -> IO a
reify J (Interp a)
x = JValue -> a
forall a. Coercible a => JValue -> a
unsafeUncoerce (JValue -> a) -> (J (Interp a) -> JValue) -> J (Interp a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. J (Interp a) -> JValue
forall (a :: JType). SingI a => J a -> JValue
JObject (J (Interp a) -> a) -> IO (J (Interp a)) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (J (Interp a) -> IO (J (Interp a))
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
newLocalRef J (Interp a)
x :: IO (J (Ty a)))
class Interpretation a => Reflect a where
reflect :: a -> IO (J (Interp a))
default reflect :: (Coercible a, Interp a ~ Ty a) => a -> IO (J (Interp a))
reflect a
x = J (Interp a) -> IO (J (Interp a))
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
newLocalRef (a -> J (Interp a)
forall (ty :: JType) a.
(ty ~ Ty a, Coercible a, IsReferenceType ty) =>
a -> J ty
jobject a
x)
reifyMVector
:: Storable a
=> (JArray ty -> IO (Ptr a))
-> (JArray ty -> Ptr a -> IO ())
-> JArray ty
-> IO (IOVector a)
reifyMVector :: (JArray ty -> IO (Ptr a))
-> (JArray ty -> Ptr a -> IO ()) -> JArray ty -> IO (IOVector a)
reifyMVector JArray ty -> IO (Ptr a)
mk JArray ty -> Ptr a -> IO ()
finalize JArray ty
jobj0 = do
JArray ty
jobj <- JArray ty -> IO (JArray ty)
forall o (ty :: JType). Coercible o (J ty) => o -> IO o
newGlobalRefNonFinalized JArray ty
jobj0
Int32
n <- JArray ty -> IO Int32
forall o (a :: JType). Coercible o (JArray a) => o -> IO Int32
getArrayLength JArray ty
jobj
Ptr a
ptr <- JArray ty -> IO (Ptr a)
mk JArray ty
jobj
ForeignPtr a
fptr <- Ptr a -> IO () -> IO (ForeignPtr a)
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr a
ptr (IO () -> IO (ForeignPtr a)) -> IO () -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ JArray ty -> Ptr a -> IO ()
finalize JArray ty
jobj Ptr a
ptr
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` JArray ty -> IO ()
forall o (ty :: JType). Coercible o (J ty) => o -> IO ()
deleteGlobalRefNonFinalized JArray ty
jobj
IOVector a -> IO (IOVector a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr a -> Int -> IOVector a
forall a s. Storable a => ForeignPtr a -> Int -> MVector s a
MVector.unsafeFromForeignPtr0 ForeignPtr a
fptr (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n))
reflectMVector
:: Storable a
=> (Int32 -> IO (JArray ty))
-> (JArray ty -> Int32 -> Int32 -> Ptr a -> IO ())
-> IOVector a
-> IO (JArray ty)
reflectMVector :: (Int32 -> IO (JArray ty))
-> (JArray ty -> Int32 -> Int32 -> Ptr a -> IO ())
-> IOVector a
-> IO (JArray ty)
reflectMVector Int32 -> IO (JArray ty)
newfun JArray ty -> Int32 -> Int32 -> Ptr a -> IO ()
fill IOVector a
mv = do
let (ForeignPtr a
fptr, Int
n) = IOVector a -> (ForeignPtr a, Int)
forall a s. Storable a => MVector s a -> (ForeignPtr a, Int)
MVector.unsafeToForeignPtr0 IOVector a
mv
JArray ty
jobj <- Int32 -> IO (JArray ty)
newfun (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fptr ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ JArray ty -> Int32 -> Int32 -> Ptr a -> IO ()
fill JArray ty
jobj Int32
0 (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
JArray ty -> IO (JArray ty)
forall (m :: * -> *) a. Monad m => a -> m a
return JArray ty
jobj
withStatic [d|
instance (SingI ty, IsReferenceType ty) => Interpretation (J ty) where type Interp (J ty) = ty
instance Interpretation (J ty) => Reify (J ty)
instance Interpretation (J ty) => Reflect (J ty)
instance Interpretation () where type Interp () = 'Class "java.lang.Short"
instance Reify () where reify _ = return ()
instance Reflect () where reflect () = new (0 :: Int16)
instance Interpretation ByteString where
type Interp ByteString = 'Array ('Prim "byte")
instance Reify ByteString where
reify jobj = do
n <- getArrayLength (unsafeCast jobj)
bytes <- getByteArrayElements jobj
bs <- BS.packCStringLen (bytes, fromIntegral n)
releaseByteArrayElements jobj bytes
return bs
instance Reflect ByteString where
reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do
arr <- newByteArray (fromIntegral n)
setByteArrayRegion arr 0 (fromIntegral n) content
return arr
instance Interpretation Bool where
type Interp Bool = 'Class "java.lang.Boolean"
instance Reify Bool where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Boolean")
m <- getMethodID klass "booleanValue"
(methodSignature [] (SPrim "boolean"))
deleteLocalRef klass
return m
callBooleanMethod jobj method []
instance Reflect Bool where
reflect = new
instance Interpretation CChar where
type Interp CChar = 'Class "java.lang.Byte"
instance Reify CChar where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Byte")
m <- getMethodID klass "byteValue"
(methodSignature [] (SPrim "byte"))
deleteLocalRef klass
return m
callByteMethod jobj method []
instance Reflect CChar where
reflect = Language.Java.Unsafe.new
instance Interpretation Int16 where
type Interp Int16 = 'Class "java.lang.Short"
instance Reify Int16 where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Short")
m <- getMethodID klass "shortValue"
(methodSignature [] (SPrim "short"))
deleteLocalRef klass
return m
callShortMethod jobj method []
instance Reflect Int16 where
reflect = new
instance Interpretation Int32 where
type Interp Int32 = 'Class "java.lang.Integer"
instance Reify Int32 where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Integer")
m <- getMethodID klass "intValue"
(methodSignature [] (SPrim "int"))
deleteLocalRef klass
return m
callIntMethod jobj method []
instance Reflect Int32 where
reflect = new
instance Interpretation Int64 where
type Interp Int64 = 'Class "java.lang.Long"
instance Reify Int64 where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Long")
m <- getMethodID klass "longValue"
(methodSignature [] (SPrim "long"))
deleteLocalRef klass
return m
callLongMethod jobj method []
instance Reflect Int64 where
reflect = new
instance Interpretation Word16 where
type Interp Word16 = 'Class "java.lang.Character"
instance Reify Word16 where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Character")
m <- getMethodID klass "charValue"
(methodSignature [] (SPrim "char"))
deleteLocalRef klass
return m
fromIntegral <$> callCharMethod jobj method []
instance Reflect Word16 where
reflect = new
instance Interpretation Double where
type Interp Double = 'Class "java.lang.Double"
instance Reify Double where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Double")
m <- getMethodID klass "doubleValue"
(methodSignature [] (SPrim "double"))
deleteLocalRef klass
return m
callDoubleMethod jobj method []
instance Reflect Double where
reflect = new
instance Interpretation Float where
type Interp Float = 'Class "java.lang.Float"
instance Reify Float where
reify jobj = do
let method = unsafeDupablePerformIO $ do
klass <- getClass (SClass "java.lang.Float")
m <- getMethodID klass "floatValue"
(methodSignature [] (SPrim "float"))
deleteLocalRef klass
return m
callFloatMethod jobj method []
instance Reflect Float where
reflect = new
instance Interpretation Text where
type Interp Text = 'Class "java.lang.String"
instance Reify Text where
reify jobj = do
sz <- getStringLength jobj
cs <- getStringChars jobj
txt <- Text.fromPtr cs (fromIntegral sz)
releaseStringChars jobj cs
return txt
instance Reflect Text where
reflect x =
Text.useAsPtr x $ \ptr len ->
newString ptr (fromIntegral len)
instance Interpretation (IOVector Word16) where
type Interp (IOVector Word16) = 'Array ('Prim "char")
instance Reify (IOVector Word16) where
reify = reifyMVector getCharArrayElements releaseCharArrayElements
instance Reflect (IOVector Word16) where
reflect = reflectMVector newCharArray setCharArrayRegion
instance Interpretation (IOVector Int16) where
type Interp (IOVector Int16) = 'Array ('Prim "short")
instance Reify (IOVector Int16) where
reify = reifyMVector getShortArrayElements releaseShortArrayElements
instance Reflect (IOVector Int16) where
reflect = reflectMVector newShortArray setShortArrayRegion
instance Interpretation (IOVector Int32) where
type Interp (IOVector Int32) = 'Array ('Prim "int")
instance Reify (IOVector Int32) where
reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements)
instance Reflect (IOVector Int32) where
reflect = reflectMVector (newIntArray) (setIntArrayRegion)
instance Interpretation (IOVector Int64) where
type Interp (IOVector Int64) = 'Array ('Prim "long")
instance Reify (IOVector Int64) where
reify = reifyMVector getLongArrayElements releaseLongArrayElements
instance Reflect (IOVector Int64) where
reflect = reflectMVector newLongArray setLongArrayRegion
instance Interpretation (IOVector Float) where
type Interp (IOVector Float) = 'Array ('Prim "float")
instance Reify (IOVector Float) where
reify = reifyMVector getFloatArrayElements releaseFloatArrayElements
instance Reflect (IOVector Float) where
reflect = reflectMVector newFloatArray setFloatArrayRegion
instance Interpretation (IOVector Double) where
type Interp (IOVector Double) = 'Array ('Prim "double")
instance Reify (IOVector Double) where
reify = reifyMVector (getDoubleArrayElements) (releaseDoubleArrayElements)
instance Reflect (IOVector Double) where
reflect = reflectMVector (newDoubleArray) (setDoubleArrayRegion)
instance Interpretation (IOVector a) => Interpretation (Vector a) where
type Interp (Vector a) = Interp (IOVector a)
instance (Storable a, Reify (IOVector a)) => Reify (Vector a) where
reify = Vector.freeze <=< reify
instance (Storable a, Reflect (IOVector a)) => Reflect (Vector a) where
reflect = reflect <=< Vector.thaw
instance Interpretation a => Interpretation [a] where
type Interp [a] = 'Array (Interp a)
instance Reify a => Reify [a] where
reify jobj = do
n <- getArrayLength jobj
forM [0..n-1] $ \i -> do
jx <- getObjectArrayElement jobj i
x <- reify jx
deleteLocalRef jx
return x
instance Reflect a => Reflect [a] where
reflect xs = do
let n = fromIntegral (length xs)
array <- newArray n :: IO (J ('Array (Interp a)))
forM_ (zip [0..n-1] xs) $ \(i, x) -> do
jx <- reflect x
setObjectArrayElement array i jx
deleteLocalRef jx
return array
|]