{-# LANGUAGE Haskell2010
    , GeneralizedNewtypeDeriving
    , DeriveDataTypeable
    , CPP
 #-}
{-# OPTIONS
    -Wall
    -fno-warn-missing-signatures
    -fno-warn-name-shadowing
 #-}

-- | INTERNAL module:
-- The Java Monad Transformer. Most of its API is re-exported by "Foreign.Java"
module Foreign.Java.JavaMonad where


import Control.Monad.State hiding (void)
import qualified Control.Monad.State as State

import Data.Int
import Data.Word

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

import Foreign.Java.JNI.Types (
    JObject (..),
    JThrowable (..)
  )

import Foreign hiding (void)
import Foreign.C.String

import Foreign.Java.Util

import Control.Concurrent
import Control.Exception
import Data.Typeable


io :: IO a -> Java a
-- ^ Short for 'liftIO' and restricted to the 'Java' monad.
io = liftIO


-- | An exception in either the Java Virtual Machine or during
-- instantiating the Virtual Machine.
data JavaException =
        -- | An exception that occurred during the initialization
        -- of the virtual machine. Thrown by 'runJava', 'runJava'',
        -- or 'initJava'.
        JvmException String [String]

        -- | An exception that occurred inside the virtual machine.
        -- Thrown by those functions ending with a capital @E@.
      | JavaException String JThrowable
    deriving Typeable

instance Show JavaException where
    show (JvmException jvmlibPath args) =
        "JvmException: jvmlibPath = " ++ jvmlibPath
            ++ ", arguments = " ++ show args
    show (JavaException strMessage _throwable) =
        "JavaException: " ++ strMessage

instance Exception JavaException


-- | A reference to an instance of a Java Virtual Machine.
newtype JVM = JVM (Ptr Core.JVM)
    deriving Show


-- | The State of a virtual machine, running in the Java
-- Monad (which is a State Monad wrapped around the IO
-- Monad with JVMState as additional State).
--
-- All the accessor functions are INTERNAL.
data JVMState = JVMState {

    -- | INTERNAL The actual pointer to the virtual machine.
    jvmPtr :: Ptr Core.JVM,

    -- | INTERNAL Whether this virtual machine instance should
    -- be talked to using safe or unsafe calls.
    --
    -- See also 'setSafe' and 'getSafe'.
    jvmSafe :: Bool,

    -- | INTERNAL The cached methodID of Object.toString
    jvmToString :: Maybe (JObject -> Java (Maybe String)),

    -- | INTERNAL The cached methodID of Object.hashCode
    jvmHashCode :: Maybe (JObject -> Java Int32),

    jvmGetC :: Maybe (Maybe JObject -> Int32 -> Java Word16),
    jvmGetB :: Maybe (Maybe JObject -> Int32 -> Java Int8),
    jvmGetS :: Maybe (Maybe JObject -> Int32 -> Java Int16),
    jvmGetI :: Maybe (Maybe JObject -> Int32 -> Java Int32),
    jvmGetJ :: Maybe (Maybe JObject -> Int32 -> Java Int64),
    jvmGetF :: Maybe (Maybe JObject -> Int32 -> Java Float),
    jvmGetD :: Maybe (Maybe JObject -> Int32 -> Java Double),
    jvmGetZ :: Maybe (Maybe JObject -> Int32 -> Java Bool),
    jvmGetL :: Maybe (Maybe JObject -> Int32 -> Java (Maybe JObject)),

    jvmSetC :: Maybe (Maybe JObject -> Int32 -> Word16 -> Java ()),
    jvmSetB :: Maybe (Maybe JObject -> Int32 -> Int8 -> Java ()),
    jvmSetS :: Maybe (Maybe JObject -> Int32 -> Int16 -> Java ()),
    jvmSetI :: Maybe (Maybe JObject -> Int32 -> Int32 -> Java ()),
    jvmSetJ :: Maybe (Maybe JObject -> Int32 -> Int64 -> Java ()),
    jvmSetF :: Maybe (Maybe JObject -> Int32 -> Float -> Java ()),
    jvmSetD :: Maybe (Maybe JObject -> Int32 -> Double -> Java ()),
    jvmSetZ :: Maybe (Maybe JObject -> Int32 -> Bool -> Java ()),
    jvmSetL :: Maybe (Maybe JObject -> Int32 -> (Maybe JObject) -> Java ())
  }

-- | Creates a JVMState and initializes it with sane default values.
-- A Pointer to the virtual machine is required in any case.
newJVMState vm = JVMState {

    jvmPtr = vm,
    jvmSafe = True,
    jvmToString = Nothing,
    jvmHashCode = Nothing,

    jvmGetC = Nothing, jvmSetC = Nothing,
    jvmGetB = Nothing, jvmSetB = Nothing,
    jvmGetS = Nothing, jvmSetS = Nothing,
    jvmGetI = Nothing, jvmSetI = Nothing,
    jvmGetJ = Nothing, jvmSetJ = Nothing,
    jvmGetF = Nothing, jvmSetF = Nothing,
    jvmGetD = Nothing, jvmSetD = Nothing,
    jvmGetZ = Nothing, jvmSetZ = Nothing,
    jvmGetL = Nothing, jvmSetL = Nothing
  }


-- | Every computation in the Java Virtual Machine happens inside the
-- Java monad. The Java monad is mightier than the IO monad, i.e.
-- IO operations can be performed in both the IO monad as well as in
-- the Java monad, but Java operations can be performed in the Java
-- monad only and not in the IO monad.
--
-- Use one of 'runJava' or 'runJava'' to perform operations in the
-- Java monad.
newtype Java a = Java { _runJava :: StateT JVMState IO a }
    deriving (Monad, MonadState JVMState, Functor, MonadIO)

-- | INTERNAL Retrieve the 'jvmPtr' from this Java Monads
-- State.
getVM :: Java (Ptr Core.JVM)
getVM   = State.get $> jvmPtr

-- | INTERNAL Retrieve 'jvmSafe' from this Java Monads Sate.
getSafe :: Java Bool
getSafe = State.get $> jvmSafe

-- | By default java methods are invoked via the FFI using
-- safe calls. Safe calls are slower than unsafe calls. This
-- function controls whether safe or unsafe calls are being
-- used to communicate with the JVM.
--
-- If your application does not invoke the JVM concurrently
-- it is mostly safe to use unsafe calls.
--
-- > runJava (setUnsafe True >> doSomething)
--
-- will perform 'doSomething' using unsafe calls.
setUnsafe mode = do
    state <- State.get
    State.put (state { jvmSafe = not mode })



newtype JavaThreadId a = JavaThreadId (MVar (Either SomeException a))

forkJava :: Java a -> Java (JavaThreadId a)
-- ^ A utility function for forking an OS thread which runs in the
-- Java Monad. It will return a 'JavaThreadId' which you can wait on
-- using 'waitJava'.
forkJava t = io $ do
    lock <- newEmptyMVar
    _ <- forkOS $ do
        result <- try $ runJava t
        putMVar lock result
    return $ JavaThreadId lock


waitJava :: JavaThreadId a -> Java (Either SomeException a)
-- ^ Wait for a Java Thread to exit. If the thread exits abnormally
-- (that is, if an exception occurred), this function will return
-- @Left SomeException@. Otherwise it will return the result of the
-- computation as @Right a@.
waitJava (JavaThreadId mvar) = io $ takeMVar mvar


runJava :: Java a -> IO a
-- ^ Run a computation with support by a Java Virtual Machine.
runJava = runJava' []


runJava' :: [String] -> Java a -> IO a
-- ^ Run a computation with support by a Java Virtual Machine,
-- initialized with the given parameters.
--
-- This function may be used only once. If you intend to call
-- it multiple times, you need to initialize the Java subsystem
-- once before. If you fail to do so, this function will tear
-- down the virtual machine once it is done.
--
-- By using 'initJava' the virtual machine will be alive during
-- the whole lifetime of your process and 'runJava'' will never
-- tear down the machine.
--
-- /NOTE: According to the Java Native Interface specification it may be possible to create multiple virtual machines within a single process. However, no implementation of the JNI seems to be capable of doing so./
--
-- This function can be used to set for example the classpath
-- of the virtual machine:
--
-- > runJava' ["-Djava.class.path=java-library-dir"] $ do
-- >     doSomething
--
-- /NOTE: java.class.path does support relative paths./
runJava' opts f = do

    str <- mapM newCString (augmentOpts opts)
    ptr <- newArray str
    vm  <- JNI.createVM' (fromIntegral $ length str) ptr

    mapM_ free str >> free ptr

    if vm == nullPtr then do
                            libjvmPath <- JNI.getLibjvmPath >>= peekCString
                            throw $ JvmException libjvmPath opts
                     else return ()
     
    (result, _) <- finally (runStateT (_runJava f) (newJVMState vm))
                           (JNI.destroyVM vm)

    return result

#ifdef FFIJNI_DEBUG
augmentOpts = ("-Xcheck:jni" :)
#else
augmentOpts = id
#endif

runJavaGui :: Java a -> IO ()
-- ^ Short hand for @runJavaGui' []@.
runJavaGui = runJavaGui' []

runJavaGui' :: [String] -> Java a -> IO ()
-- ^ Mac OS X needs some special treatment for initializing
-- graphical applications, namely a Cocoa Runloop needs to be present
-- on the main thread. Since the main thread is the application
-- that the JVM was invoked from this has two consequences:
-- (1) A runloop needs to be created on the main thread
-- manually and (2) the main thread is not usable for your application.
--
-- On Mac OS X this function will fork an os thread using 'forkJava'
-- and start the Cocoa main event loop. This means that this function
-- must be called on the main thread and that it will never terminate
-- (since the cocoa event queue will be running there forever).
--
-- Note that this implies that you link your application with
-- the threaded runtime (`-threaded` in GHC).
--
-- Typically your application should look like this:
--
-- > main = runJavaGui $ do
-- >     stuffYourApplicationDoes
--
-- On all other platforms this is exactly the same as 'runJava''
-- (minus the fact that it returns @()@).
#if defined(FFIJNI_MACOSX) && defined(FFIJNI_OSX_GUI)
runJavaGui' opts java = runJava' opts $ do
        _ <- forkJava java
        io JNI.runCocoaMain
#else
runJavaGui' opts javaGui = runJava' opts javaGui >> return ()
#endif

initJava :: [String] -> IO ()
-- ^ Initializes the Java Virtual Machine so that it can
-- be used by subsequent invocations of 'runJava'. Note that
-- once you start the virtual machine it will be runing throughout
-- the whole lifetime of the main thread of your application.
initJava opts = runJava' opts persistVM

persistVM :: Java ()
persistVM = do
    vm <- getVM
    liftIO $ JNI.persistVM vm
    return ()