calculator.hs

calculator.hs

import Foreign.Java
import Data.Maybe

import Foreign.Java.Bindings.Support




import Data.Int
import Data.Word
import Data.Maybe

import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import qualified Foreign.Java.JNI.Safe as JNI
import qualified Foreign.Java.JNI.Types as Core
import qualified Foreign.Java.Types as Types
import Foreign hiding (void)

import System.Win32.DebugApi(debugBreak)





main :: IO ()
main = do
    initJava ["-XX:+CreateMinidumpOnCrash"]
    runJava $ do
    
    
    (Just jFrameClass)  <- getClass "javax.swing.JFrame"
    (Just jButtonClass) <- getClass "javax.swing.JButton"
    (Just jGridLayoutClass) <- getClass "java.awt.GridLayout"
    (Just jEventObject) <- getClass "java.util.EventObject"

    setVisible   <- jFrameClass `bindMethod` "setVisible" ::= boolean --> void
    addComponent <- jFrameClass `bindMethod` "add" ::= object "java.awt.Component"
                                                   --> object "java.awt.Component"
    setLocation  <- jFrameClass `bindMethod` "setLocationRelativeTo" ::= object "java.awt.Component"
                                                                     --> void
    setSize'     <- jFrameClass `bindMethod` "setSize" ::= int --> int --> void
    let setSize obj (a, b) = setSize' obj a b
    setLayout    <- jFrameClass `bindMethod` "setLayout" ::= object "java.awt.LayoutManager"
                                                         --> void

    addActionListener <- jButtonClass
        `bindMethod` "addActionListener" ::= object "java.awt.event.ActionListener" --> void
    getText <- jButtonClass `bindMethod` "getText" ::= string
    getSource <- jEventObject `bindMethod` "getSource" ::= object "java.lang.Object"
	

    (Just jButtonConstr)     <- getConstructor jButtonClass $ string
    (Just jGridLayoutConstr) <- getConstructor jGridLayoutClass $ int --> int
    
    (Just jFrame) <- newObject jFrameClass
    
    newObjectFrom jGridLayoutConstr 4 4 >>= setLayout jFrame

    buttons <- mapM (newObjectFrom jButtonConstr)
                    [ "1", "2", "3", "*"
                    , "4", "5", "6", "-"
                    , "7", "8", "9", "·"
                    , "C", "0", "=", "÷" ]
    
    mapM_ (addComponent jFrame) buttons

    let action  self method args= do
            --io $ debugBreak
            io $ putStrLn ""
            io $ putStrLn "Let's have some fun!"
            (Just arg) <- at args 0
            ms   <- toString method
            argS <- toString arg
            (Just source) <- getSource arg
            (Just val) <- (getText source)
            io $ putStrLn $ "button text: " ++ val
            io $ putStrLn $ "\nmethod: " ++ ms
            io $ putStrLn $ "args: " ++ argS

    listener <- sushimaki2 "java.awt.event.ActionListener" action

    mapM_ (flip addActionListener (Just listener) . fromJust) buttons

    jFrame `setSize` (400, 300)
    jFrame `setLocation` Nothing
    jFrame `setVisible` True



type Callback = JObject
                -> JObject
                -> JArray Types.L
                -> Java ()

wrap2 :: Callback-> IO (FunPtr WrappedFun)
wrap2 f = do

    let func vm _self _method _args = do

            --putStrLn $ "method: " ++ show ( toString _method)
            putStrLn ""
            putStrLn $ show _self
            putStrLn $ show _method
            putStrLn $ show _args

            --let dummy _ = 
            _self' <- JNI.newGlobalRef vm _self
            _method' <- JNI.newGlobalRef vm _method
            _args' <- JNI.newGlobalRef vm _args

            _pself <- newForeignPtr JNI.release _self'
            _pmethod <- newForeignPtr JNI.release _method'
            _pargs <- newForeignPtr JNI.release _args'

            let self = Core.JObject _pself
            let met  = Core.JObject _pmethod
            let args = Core.JArray 1 _pargs :: JArray Types.L
            --let action = do

            --    (Just arg) <- at args 0
            --    argS <- toString arg
            --    io $ putStrLn ""
            --    io $ putStrLn $ "method: " ++ met
            --    io $ putStrLn $ "args: " ++ argS
            --runJava_ vm action
            runJava_ vm $ f self met args
            return nullPtr
            
    func' <- wrap_ func

    return func'

intify2 :: Callback -> IO Int64
intify2 = fmap (fromIntegral . ptrToIntPtr . castFunPtrToPtr) . wrap2




sushimaki2 :: String -> Callback -> Java JObject
sushimaki2 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 (intify2 func) >>= makeFunction (Just iface)
    return impl