Internal.hs

-- | Internal functions to invoke JNI methods
--
-- The functions in this module avoid using
-- 'Language.Java.Coercible' so they can be reused in interfaces which
-- use other ways to convert between Haskell and Java values.
--
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}

module Language.Java.Internal
  ( newJ
  , callToJValue
  , callStaticToJValue
  , getStaticFieldAsJValue
  , getClass
  , setGetClassFunction
  ) where

import Data.IORef
import Data.Singletons (SingI(..), SomeSing(..))
import Foreign.JNI hiding (throw)
import Foreign.JNI.Types
import qualified Foreign.JNI.String as JNI
import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO)

-- | Sets the function to use for loading classes.
--
-- 'findClass' is used by default.
--
setGetClassFunction
  :: (forall ty. IsReferenceType ty => Sing (ty :: JType) -> IO JClass)
  -> IO ()
setGetClassFunction f = writeIORef getClassFunctionRef $ GetClassFun f

-- | Yields a class referece. It behaves as 'findClass' unless
-- 'setGetClassFunction' is used.
getClass :: IsReferenceType ty => Sing (ty :: JType) -> IO JClass
getClass s = readIORef getClassFunctionRef >>= \(GetClassFun f) -> f s

newtype GetClassFun =
    GetClassFun (forall ty. IsReferenceType ty =>
                   Sing (ty :: JType) -> IO JClass
                )

{-# NOINLINE getClassFunctionRef #-}
getClassFunctionRef :: IORef GetClassFun
getClassFunctionRef =
    unsafePerformIO $ newIORef (GetClassFun (findClass . referenceTypeName))

newJ
  :: forall sym ty.
     ( ty ~ 'Class sym
     , SingI ty
     )
  => [SomeSing JType] -- ^ Singletons of argument types
  -> [JValue]
  -> IO (J ty)
{-# INLINE newJ #-}
newJ argsings args = do
    let voidsing = sing :: Sing 'Void
        klass = unsafeDupablePerformIO $ do
          lk <- getClass (sing :: Sing ('Class sym))
          gk <- newGlobalRef lk
          deleteLocalRef lk
          return gk
    unsafeCast <$> newObject klass (methodSignature argsings voidsing) args

callToJValue
  :: forall ty1 k. (IsReferenceType ty1, SingI ty1)
  => Sing (k :: JType)
  -> J ty1 -- ^ Any object
  -> JNI.String -- ^ Method name
  -> [SomeSing JType] -- ^ Singletons of argument types
  -> [JValue] -- ^ Arguments
  -> IO JValue
{-# INLINE callToJValue #-}
callToJValue retsing obj mname argsings args = do
    let klass = unsafeDupablePerformIO $ do
                  lk <- getClass (sing :: Sing ty1)
                  gk <- newGlobalRef lk
                  deleteLocalRef lk
                  return gk
        method = unsafeDupablePerformIO $ getMethodID klass mname (methodSignature argsings retsing)
    case retsing of
      SPrim "boolean" -> JBoolean . fromIntegral . fromEnum <$>
                           callBooleanMethod obj method args
      SPrim "byte" -> JByte <$> callByteMethod obj method args
      SPrim "char" -> JChar <$> callCharMethod obj method args
      SPrim "short" -> JShort <$> callShortMethod obj method args
      SPrim "int" -> JInt <$> callIntMethod obj method args
      SPrim "long" -> JLong <$> callLongMethod obj method args
      SPrim "float" -> JFloat <$> callFloatMethod obj method args
      SPrim "double" -> JDouble <$> callDoubleMethod obj method args

      SVoid -> do
        callVoidMethod obj method args
        -- The void result is not inspected.
        return (error "inspected output of method returning void")
      _ -> JObject <$> callObjectMethod obj method args

callStaticToJValue
  :: Sing (k :: JType)
  -> JNI.String -- ^ Class name
  -> JNI.String -- ^ Method name
  -> [SomeSing JType] -- ^ Singletons of argument types
  -> [JValue] -- ^ Arguments
  -> IO JValue
{-# INLINE callStaticToJValue #-}
callStaticToJValue retsing cname mname argsings args = do
    let klass = unsafeDupablePerformIO $ do
                  lk <- getClass (SClass (JNI.toChars cname))
                  gk <- newGlobalRef lk
                  deleteLocalRef lk
                  return gk
        method = unsafeDupablePerformIO $ getStaticMethodID klass mname (methodSignature argsings retsing)
    case retsing of
      SPrim "boolean" -> JBoolean . fromIntegral . fromEnum <$>
                           callStaticBooleanMethod klass method args
      SPrim "byte" -> JByte <$> callStaticByteMethod klass method args
      SPrim "char" -> JChar <$> callStaticCharMethod klass method args
      SPrim "short" -> JShort <$> callStaticShortMethod klass method args
      SPrim "int" -> JInt <$> callStaticIntMethod klass method args
      SPrim "long" -> JLong <$> callStaticLongMethod klass method args
      SPrim "float" -> JFloat <$> callStaticFloatMethod klass method args
      SPrim "double" -> JDouble <$> callStaticDoubleMethod klass method args
      SVoid -> do
        callStaticVoidMethod klass method args
        -- The void result is not inspected.
        return (error "inspected output of method returning void")
      _ -> JObject <$> callStaticObjectMethod klass method args

getStaticFieldAsJValue
  :: Sing (ty :: JType)
  -> JNI.String -- ^ Class name
  -> JNI.String -- ^ Static field name
  -> IO JValue
{-# INLINE getStaticFieldAsJValue #-}
getStaticFieldAsJValue retsing cname fname = do
  let klass = unsafeDupablePerformIO $ do
                lk <- getClass (SClass (JNI.toChars cname))
                gk <- newGlobalRef lk
                deleteLocalRef lk
                return gk
      field = unsafeDupablePerformIO $ getStaticFieldID klass fname (signature retsing)
  case retsing of
    SPrim "boolean" -> JBoolean <$> getStaticBooleanField klass field
    SPrim "byte" -> JByte <$> getStaticByteField klass field
    SPrim "char" -> JChar <$> getStaticCharField klass field
    SPrim "short" -> JShort <$> getStaticShortField klass field
    SPrim "int" -> JInt <$> getStaticIntField klass field
    SPrim "long" -> JLong <$> getStaticLongField klass field
    SPrim "float" -> JFloat <$> getStaticFloatField klass field
    SPrim "double" -> JDouble <$> getStaticDoubleField klass field
    SVoid -> fail "getStaticField cannot yield an object of type void"
    _ -> JObject <$> getStaticObjectField klass field