#line 1 "src/Foreign/Java/Bindings.cpphs"
{-# LANGUAGE Haskell2010
    , TypeFamilies
    , FlexibleContexts
    , FlexibleInstances
    , TypeSynonymInstances
    , MultiParamTypeClasses
    , ScopedTypeVariables
    , NoImplicitPrelude
 #-}
{-# OPTIONS
    -Wall
 #-}

-- |
-- Module       : Foreign.Java.Bindings.Support
-- Copyright    : (c) Julian Fleischer 2013
-- License      : MIT (See LICENSE file in cabal package)
--
-- Maintainer   : julian.fleischer@fu-berlin.de
-- Stability    : experimental
-- Portability  : non-portable (TypeFamilies)
--
-- This module provides type classes and instances for
-- supporting the high level bindings. This module should
-- not be imported directly.
module Foreign.Java.Bindings where

import Haskell.X.Prelude hiding (toList, arr)

import Control.Monad.State hiding (void)

import Foreign
import Foreign.C

import Foreign.Java
import Foreign.Java.JavaMonad
import Foreign.Java.Types as T
import qualified Foreign.Java.JNI.Safe as JNI
import qualified Foreign.Java.JNI.Types as Core


---------------
-- Utilities --
---------------


object' :: [Char] -> Q
object' = T.object'


------------------------------
-- Primitive argument types --
------------------------------

class JBoolean a  where toBoolean :: a -> Java Bool
class JChar a     where toChar    :: a -> Java Word16
class JByte a     where toByte    :: a -> Java Int8
class JShort a    where toShort   :: a -> Java Int16
class JInt a      where toInt     :: a -> Java Int32
class JLong a     where toLong    :: a -> Java Int64
class JFloat a    where toFloat   :: a -> Java Float
class JDouble a   where toDouble  :: a -> Java Double


instance JBoolean Bool   where toBoolean = return

instance JChar Char      where toChar = return . fromIntegral . fromEnum
instance JChar Int8      where toChar = return . fromIntegral
instance JChar Word16    where toChar = return

instance JByte Int8      where toByte = return

instance JShort Int8     where toShort = return . fromIntegral
instance JShort Word8    where toShort = return . fromIntegral
instance JShort Int16    where toShort = return

instance JInt Int        where toInt = return . fromIntegral
instance JInt Int8       where toInt = return . fromIntegral
instance JInt Word8      where toInt = return . fromIntegral
instance JInt Int16      where toInt = return . fromIntegral
instance JInt Word16     where toInt = return . fromIntegral
instance JInt Int32      where toInt = return

instance JLong Int       where toLong = return . fromIntegral
instance JLong Int8      where toLong = return . fromIntegral
instance JLong Word8     where toLong = return . fromIntegral
instance JLong Int16     where toLong = return . fromIntegral
instance JLong Word16    where toLong = return . fromIntegral
instance JLong Int32     where toLong = return . fromIntegral
instance JLong Word32    where toLong = return . fromIntegral
instance JLong Int64     where toLong = return

instance JFloat CFloat   where toFloat = return . realToFrac
instance JFloat Float    where toFloat = return

instance JDouble CDouble where toDouble = return . realToFrac
instance JDouble Double  where toDouble = return


--------------------------
-- Array argument types --
--------------------------

class Array a where
    asMaybeArrayObject :: a -> Java (Maybe JObject)


----------------------------
-- Primitive result types --
----------------------------











-- | The result of a function call that is of type @boolean@.
class BooleanResult m where {        toBooleanResult :: Either JThrowable Bool -> Java m }    ;    instance BooleanResult Bool where {        toBooleanResult = either (\exc -> toString exc >>= fail) return }    ;    instance BooleanResult (Either JThrowable Bool) where {        toBooleanResult = return }
-- | The result of a function call that is of type @char@.
class CharResult m where {        toCharResult :: Either JThrowable Word16 -> Java m }    ;    instance CharResult Word16 where {        toCharResult = either (\exc -> toString exc >>= fail) return }    ;    instance CharResult (Either JThrowable Word16) where {        toCharResult = return }
-- | The result of a function call that is of type @byte@.
class ByteResult m where {        toByteResult :: Either JThrowable Int8 -> Java m }    ;    instance ByteResult Int8 where {        toByteResult = either (\exc -> toString exc >>= fail) return }    ;    instance ByteResult (Either JThrowable Int8) where {        toByteResult = return }
-- | The result of a function call that is of type @short@.
class ShortResult m where {        toShortResult :: Either JThrowable Int16 -> Java m }    ;    instance ShortResult Int16 where {        toShortResult = either (\exc -> toString exc >>= fail) return }    ;    instance ShortResult (Either JThrowable Int16) where {        toShortResult = return }
-- | The result of a function call that is of type @int@.
class IntResult m where {        toIntResult :: Either JThrowable Int32 -> Java m }    ;    instance IntResult Int32 where {        toIntResult = either (\exc -> toString exc >>= fail) return }    ;    instance IntResult (Either JThrowable Int32) where {        toIntResult = return }
-- | The result of a function call that is of type @long@.
class LongResult m where {        toLongResult :: Either JThrowable Int64 -> Java m }    ;    instance LongResult Int64 where {        toLongResult = either (\exc -> toString exc >>= fail) return }    ;    instance LongResult (Either JThrowable Int64) where {        toLongResult = return }
-- | The result of a function call that is of type @float@.
class FloatResult m where {        toFloatResult :: Either JThrowable Float -> Java m }    ;    instance FloatResult Float where {        toFloatResult = either (\exc -> toString exc >>= fail) return }    ;    instance FloatResult (Either JThrowable Float) where {        toFloatResult = return }
-- | The result of a function call that is of type @double@.
class DoubleResult m where {        toDoubleResult :: Either JThrowable Double -> Java m }    ;    instance DoubleResult Double where {        toDoubleResult = either (\exc -> toString exc >>= fail) return }    ;    instance DoubleResult (Either JThrowable Double) where {        toDoubleResult = return }

-- | The result of a function call that is of type @void@.
class VoidResult m where
    toVoidResult :: Either JThrowable () -> Java m
    
instance VoidResult () where
    toVoidResult = either (\exc -> toString exc >>= fail) return

instance VoidResult (Either JThrowable ()) where
    toVoidResult = return
    
instance VoidResult (Maybe JThrowable) where
    toVoidResult = return . either Just (const Nothing)


------------------------
-- Array result types --
------------------------

-- | An array result of a function call.
class JavaArray (ArrayResultType m) (ArrayResultComponent m) => ArrayResult m where
    -- | The JVM machine type of the components of the array.
    type ArrayResultType m

    -- | The type of the component of the array as returned by
    -- the low level JNI call.
    type ArrayResultComponent m

    -- | Convert the array to a sophisticated type.
    toArrayResult :: Either JThrowable (Maybe (JArray (ArrayResultType m))) -> Java m

instance ArrayResult a => ArrayResult (Either JThrowable a) where
    type ArrayResultType (Either JThrowable a) = ArrayResultType a
    type ArrayResultComponent (Either JThrowable a) = ArrayResultComponent a

    toArrayResult = either (return . Left) (toArrayResult . Right)









instance ArrayResult [Bool] where {        type ArrayResultType [Bool] = T.Z ;        type ArrayResultComponent [Bool] = Bool ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Word16] where {        type ArrayResultType [Word16] = T.C ;        type ArrayResultComponent [Word16] = Word16 ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Int8] where {        type ArrayResultType [Int8] = T.B ;        type ArrayResultComponent [Int8] = Int8 ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Int16] where {        type ArrayResultType [Int16] = T.S ;        type ArrayResultComponent [Int16] = Int16 ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Int32] where {        type ArrayResultType [Int32] = T.I ;        type ArrayResultComponent [Int32] = Int32 ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Int64] where {        type ArrayResultType [Int64] = T.J ;        type ArrayResultComponent [Int64] = Int64 ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Float] where {        type ArrayResultType [Float] = T.F ;        type ArrayResultComponent [Float] = Float ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }
instance ArrayResult [Double] where {        type ArrayResultType [Double] = T.D ;        type ArrayResultComponent [Double] = Double ;                toArrayResult = either (\exc -> toString exc >>= fail)                                (maybe (return []) toList) }


instance ArrayResult [Char] where
    type ArrayResultType [Char] = T.C
    type ArrayResultComponent [Char] = Word16

    toArrayResult = either (\exc -> toString exc >>= fail)
                           (maybe (return [])
                                  (fmap (map (toEnum . fromIntegral)) . toList))

instance ArrayResult [[Char]] where
    type ArrayResultType [[Char]] = T.L
    type ArrayResultComponent [[Char]] = Maybe JObject

    toArrayResult =
        either (\exc -> toString exc >>= fail)
               (maybe (return [])
                      (\arr -> toList arr >>= mapM (maybe (return "") toString)))



-----------------------
-- All other objects --
-----------------------

newtype AsString o = AsString [Char]
    deriving (Eq, Show, Ord)

newtype AsList a o = AsList [a]
    deriving (Eq, Show, Ord)

class ObjectToList o e where
    objectToList :: o -> JObject -> Java [e]

-- | The result of a function call that is of type @object@.
class ObjectResult m where
    -- | 
    toObjectResult :: Either JThrowable (Maybe JObject) -> Java m

instance ObjectResult (AsString a) where
    toObjectResult = fmap AsString . either (\exc -> toString exc >>= fail)
                                            (maybe (return "null") toString)

instance ObjectToList o e => ObjectResult (AsList e o) where
    toObjectResult = fmap AsList . either (\exc -> toString exc >>= fail)
                                          (maybe (return []) (objectToList (undefined :: o)))

instance UnsafeCast a => ObjectResult (Value a) where
    toObjectResult = either (return . Fail)
                            (maybe (return NoValue)
                                   (fmap Value . unsafeFromJObject))

instance UnsafeCast a => ObjectResult (Either JThrowable a) where
    toObjectResult = either (return . Left)
                            (maybe (fmap Left nullPointer)
                                   (fmap Right . unsafeFromJObject))
      where
        nullPointer :: Java JThrowable
        nullPointer = do
            (Just clazz) <- getClass "java.lang.NullPointerException"
            (Just (Core.JObject obj)) <- newObject clazz
            return $ Core.JThrowable (castForeignPtr obj)

instance UnsafeCast a => ObjectResult (Either (Maybe JThrowable) a) where
    toObjectResult = either (return . Left . Just)
                            (maybe (return (Left Nothing))
                                   (fmap Right . unsafeFromJObject))

instance UnsafeCast a => ObjectResult (Maybe a) where
    toObjectResult = either (\exc -> toString exc >>= fail)
                            (maybe (return Nothing)
                                   (fmap Just . unsafeFromJObject))


---------------------------------------------------
-- Advanced features (Callbacks, Subtyping, ...) --
---------------------------------------------------


-- | A convenient alternative to 'isInstanceOf'.
--
-- Minimal complete definition: 'coerce' or 'whenInstanceOf'.
class InstanceOf a where
    type CoercedType a

    -- | Check if the object of type @a@ is an instance
    -- of the type represented by @b@. 
    instanceOf :: JavaObject o => o -> a -> Java Bool

    -- | Check if the object of type @a@ is an instance
    -- of the type @c@, represented by @b@. If so, it will coerce
    -- the object of type @a@ and pass it to the given action.
    --
    -- If @a@ was an instance of @c@ (where @c@ is represented
    -- by @b@) this function will return @'Just' d@, where @d@ is
    -- the result of the optional computation. If not, 'Nothing'
    -- is returned.
    whenInstanceOf :: JavaObject o => o -> a -> (CoercedType a -> Java d) -> Java (Maybe d)

    -- | Coerces the given object of type @a@ to an object of
    -- @c@, where @c@ is represented by a value of type @b@.
    -- Returns @'Nothing'@ if this is not possible.
    coerce :: JavaObject o => o -> a -> Java (Maybe (CoercedType a))

    instanceOf o t =
        whenInstanceOf o t (return . const ())
            >>= return . maybe False (const True)

    whenInstanceOf o t a =
        coerce o t >>= maybe (return Nothing) (fmap Just . a)

    coerce o t = whenInstanceOf o t return

-- | For INTERNAL use only. Is however not in a hidden module,
-- so that other libraries can link against it.
class UnsafeCast a where
    -- | For INTERNAL use only. Do not use yourself.
    unsafeFromJObject :: JObject -> Java a



---------------
-- Callbacks --
---------------


registerCallbacks :: Core.JClass -> Java Bool
-- ^ Yepp. Register callbacks. Do it.
registerCallbacks (Core.JClass ptr) = do
    vm <- getVM
    io $ withForeignPtr ptr $ \clazz -> JNI.registerCallbacks vm clazz


-- | A wrapped function can be used as a callback from the
-- JVM into the Haskell runtime environment.
type WrappedFunc = Ptr Core.JVM -- Ptr to JEnv
               -> Ptr Core.JObjectRef -- Ptr to this, a proxy
               -> Ptr Core.JObjectRef -- Ptr to method, the requested method
               -> Ptr Core.JObjectRef -- Ptr to a JObject-Array (Object[]), the arguments
               -> IO (Ptr Core.JObjectRef) -- Returns a pointer to the result

type InterfaceFunc = JObject -> JObject -> JObject -> Java (Maybe JObject)

runJava_ :: Ptr Core.JVM -> Java a -> IO a
runJava_ vm f = runStateT (_runJava f) (newJVMState vm) >>= return . fst

foreign import ccall safe "wrapper"
    wrap_ :: WrappedFunc -> IO (FunPtr WrappedFunc)

foreign export ccall freeFunPtr :: FunPtr WrappedFunc -> IO ()


freeFunPtr :: FunPtr WrappedFunc -> IO ()
freeFunPtr ptr = freeHaskellFunPtr ptr


implementInterfaceBy :: [Char] -> InterfaceFunc -> Java JObject
implementInterfaceBy ifaceName func = do
    iface <- getClass ifaceName >>= asObject . fromJust
    (Just clazz) <- getClass "HFunction"
    _success <- registerCallbacks clazz
    makeFunction <- clazz `bindStaticMethod` "makeFunction"
        ::= object "java.lang.Class" --> long --> object "java.lang.Object"
    (Just impl) <- io (intify func) >>= makeFunction (Just iface)
    return impl
  where
    wrap :: InterfaceFunc -> IO (FunPtr WrappedFunc)
    wrap f = do

        let proxyFunc vm self method args = do
                self'   <- Core.JObject <$> newForeignPtr JNI.release self
                method' <- Core.JObject <$> newForeignPtr JNI.release method
                args'   <- Core.JObject <$> newForeignPtr JNI.release args

                jobj <- runJava_ vm (f self' method' args')

                case jobj of
                    Nothing -> return nullPtr
                    Just (Core.JObject ptr) -> withForeignPtr ptr return

        wrappedFunc <- wrap_ proxyFunc

        return wrappedFunc

    intify :: InterfaceFunc -> IO Int64
    intify = fmap (fromIntegral . ptrToIntPtr . castFunPtrToPtr) . wrap


delete :: Core.JObject -> Java ()
delete (Core.JObject ptr) = io $ do
    finalizeForeignPtr ptr