diff --git a/HJVM.cabal b/HJVM.cabal new file mode 100644 --- /dev/null +++ b/HJVM.cabal @@ -0,0 +1,57 @@ +Name: HJVM +Version: 0.1 +Build-Type: Simple +cabal-version: >= 1.8 +extra-source-files: src/libjvm.dll.a,src/Language/Java/JVM/hjvm.h +stability: Experimental +author: JP Moresmau +maintainer: jp@moresmau.fr +synopsis: A library to create a Java Virtual Machine and manipulate Java objects +description: Uses FFI to access JNI to create a JVM. Then the library lets you create and manipulate Java objects. + There is also a code generator to generate wrapper Haskell code +homepage: https://github.com/JPMoresmau/HJVM +category: Language +license-file: LICENSE +license: BSD3 +copyright: Copyright 2011-2012, JP Moresmau +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: + base < 5, + containers, + mtl, + transformers, + process, + filepath, + parsec >= 3, + haskell-src-exts + exposed-modules: Language.Java.JVM.API, Language.Java.JVM.Types, Language.Java.JVM.Generator, Language.Java.JVM.JavapParser, Language.Java.JVM.SignatureParser + includes: src/Language/Java/JVM/hjvm.h + c-sources: src/Language/Java/JVM/hjvm.c + extra-libraries: jvm + ghc-options: -Wall -fno-warn-unused-do-bind + +Test-Suite hjvm-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base < 5, + Cabal >= 1.9.2, + HJVM, + HUnit, + mtl, + transformers, + parsec >= 3, + haskell-src-exts, + test-framework, + test-framework-hunit + other-modules: Language.Java.JVM.APITest, Language.Java.JVM.JavapParserTest, Language.Java.JVM.GeneratorTest, Language.Java.JVM.SignatureParserTest + ghc-options: -Wall -fno-warn-unused-do-bind + x-uses-tf: true + +source-repository head + type: git + location: git://github.com/JPMoresmau/HJVM.git diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright 2011-2012, JP Moresmau +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY +COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# HJVM + +The HJVM project aims at integrating a Java Virtual Machine inside Haskell Code. + +It allows launching a JVM from Haskell and manipulating the Java objects. + +There is a also a binding generator to generate Haskell bindings to Java objects. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/src/Language/Java/JVM/API.hs b/src/Language/Java/JVM/API.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/API.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, FlexibleContexts, FlexibleInstances, RankNTypes,MultiParamTypeClasses #-} +module Language.Java.JVM.API where + +import Language.Java.JVM.Types + +import Control.Monad +import qualified Data.Map as Map + +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Control.Concurrent.MVar +import Control.Monad.IO.Class +import Control.Monad.State + +import Text.Printf + +foreign import ccall safe "start" f_start ::CString -> IO (CLong) +foreign import ccall safe "end" f_end :: IO () +--foreign import ccall "test" test ::CInt -> IO (CInt) + +foreign import ccall safe "findClass" f_findClass :: CString -> IO (JClassPtr) +foreign import ccall safe "freeClass" f_freeClass :: JClassPtr -> IO () +foreign import ccall safe "freeObject" f_freeObject :: JObjectPtr -> IO () +foreign import ccall safe "findMethod" f_findMethod :: JClassPtr -> CString -> CString -> IO (JMethodPtr) +foreign import ccall safe "findStaticMethod" f_findStaticMethod :: JClassPtr -> CString -> CString -> IO (JMethodPtr) +foreign import ccall safe "findField" f_findField :: JClassPtr -> CString -> CString -> IO (JFieldPtr) +foreign import ccall safe "findStaticField" f_findStaticField :: JClassPtr -> CString -> CString -> IO (JFieldPtr) +foreign import ccall safe "newObject" f_newObject :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString -> IO (JObjectPtr) +foreign import ccall safe "newString" f_newString :: CWString -> CLong -> CWString-> IO (JObjectPtr) + +foreign import ccall safe "callIntMethod" f_callIntMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CLong) +foreign import ccall safe "callCharMethod" f_callCharMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CUShort) +foreign import ccall safe "callVoidMethod" f_callVoidMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO () +foreign import ccall safe "callBooleanMethod" f_callBooleanMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CUChar) +foreign import ccall safe "callByteMethod" f_callByteMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CChar) +foreign import ccall safe "callLongMethod" f_callLongMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CLong) +foreign import ccall safe "callShortMethod" f_callShortMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CShort) +foreign import ccall safe "callFloatMethod" f_callFloatMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CFloat) +foreign import ccall safe "callDoubleMethod" f_callDoubleMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CDouble) +foreign import ccall safe "callObjectMethod" f_callObjectMethod :: JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (JObjectPtr) + +foreign import ccall safe "callStaticIntMethod" f_callStaticIntMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CLong) +foreign import ccall safe "callStaticCharMethod" f_callStaticCharMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CUShort) +foreign import ccall safe "callStaticVoidMethod" f_callStaticVoidMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO () +foreign import ccall safe "callStaticBooleanMethod" f_callStaticBooleanMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CUChar) +foreign import ccall safe "callStaticByteMethod" f_callStaticByteMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CChar) +foreign import ccall safe "callStaticLongMethod" f_callStaticLongMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CLong) +foreign import ccall safe "callStaticShortMethod" f_callStaticShortMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CShort) +foreign import ccall safe "callStaticFloatMethod" f_callStaticFloatMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CFloat) +foreign import ccall safe "callStaticDoubleMethod" f_callStaticDoubleMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (CDouble) +foreign import ccall safe "callStaticObjectMethod" f_callStaticObjectMethod :: JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO (JObjectPtr) + +foreign import ccall safe "getStaticIntField" f_getStaticIntField :: JClassPtr -> JFieldPtr -> CWString-> IO (CLong) +foreign import ccall safe "getStaticBooleanField" f_getStaticBooleanField :: JClassPtr -> JFieldPtr -> CWString-> IO (CUChar) +foreign import ccall safe "getStaticCharField" f_getStaticCharField :: JClassPtr -> JFieldPtr -> CWString-> IO (CUShort) +foreign import ccall safe "getStaticShortField" f_getStaticShortField :: JClassPtr -> JFieldPtr -> CWString-> IO (CShort) +foreign import ccall safe "getStaticByteField" f_getStaticByteField :: JClassPtr -> JFieldPtr -> CWString-> IO (CChar) +foreign import ccall safe "getStaticLongField" f_getStaticLongField :: JClassPtr -> JFieldPtr -> CWString-> IO (CLong) +foreign import ccall safe "getStaticDoubleField" f_getStaticDoubleField :: JClassPtr -> JFieldPtr -> CWString-> IO (CDouble) +foreign import ccall safe "getStaticFloatField" f_getStaticFloatField :: JClassPtr -> JFieldPtr -> CWString-> IO (CFloat) +foreign import ccall safe "getStaticObjectField" f_getStaticObjectField :: JClassPtr -> JFieldPtr -> CWString-> IO (JObjectPtr) + +foreign import ccall safe "setStaticIntField" f_setStaticIntField :: JClassPtr -> JFieldPtr-> CLong -> CWString -> IO () +foreign import ccall safe "setStaticBooleanField" f_setStaticBooleanField :: JClassPtr -> JFieldPtr-> CUChar -> CWString -> IO () +foreign import ccall safe "setStaticCharField" f_setStaticCharField :: JClassPtr -> JFieldPtr-> CUShort -> CWString-> IO () +foreign import ccall safe "setStaticShortField" f_setStaticShortField :: JClassPtr -> JFieldPtr-> CShort -> CWString -> IO () +foreign import ccall safe "setStaticByteField" f_setStaticByteField :: JClassPtr -> JFieldPtr -> CChar -> CWString-> IO () +foreign import ccall safe "setStaticLongField" f_setStaticLongField :: JClassPtr -> JFieldPtr -> CLong -> CWString-> IO () +foreign import ccall safe "setStaticDoubleField" f_setStaticDoubleField :: JClassPtr -> JFieldPtr-> CDouble -> CWString-> IO () +foreign import ccall safe "setStaticFloatField" f_setStaticFloatField :: JClassPtr -> JFieldPtr-> CFloat -> CWString -> IO () +foreign import ccall safe "setStaticObjectField" f_setStaticObjectField :: JClassPtr -> JFieldPtr -> JObjectPtr -> CWString -> IO () + +foreign import ccall safe "getIntField" f_getIntField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CLong) +foreign import ccall safe "getBooleanField" f_getBooleanField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CUChar) +foreign import ccall safe "getCharField" f_getCharField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CUShort) +foreign import ccall safe "getShortField" f_getShortField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CShort) +foreign import ccall safe "getByteField" f_getByteField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CChar) +foreign import ccall safe "getLongField" f_getLongField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CLong) +foreign import ccall safe "getDoubleField" f_getDoubleField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CDouble) +foreign import ccall safe "getFloatField" f_getFloatField :: JObjectPtr -> JFieldPtr -> CWString-> IO (CFloat) +foreign import ccall safe "getObjectField" f_getObjectField :: JObjectPtr -> JFieldPtr -> CWString-> IO (JObjectPtr) + +foreign import ccall safe "setIntField" f_setIntField :: JObjectPtr -> JFieldPtr-> CLong -> CWString -> IO () +foreign import ccall safe "setBooleanField" f_setBooleanField :: JObjectPtr -> JFieldPtr-> CUChar -> CWString -> IO () +foreign import ccall safe "setCharField" f_setCharField :: JObjectPtr -> JFieldPtr-> CUShort -> CWString-> IO () +foreign import ccall safe "setShortField" f_setShortField :: JObjectPtr -> JFieldPtr-> CShort -> CWString -> IO () +foreign import ccall safe "setByteField" f_setByteField :: JObjectPtr -> JFieldPtr -> CChar -> CWString-> IO () +foreign import ccall safe "setLongField" f_setLongField :: JObjectPtr -> JFieldPtr -> CLong -> CWString-> IO () +foreign import ccall safe "setDoubleField" f_setDoubleField :: JObjectPtr -> JFieldPtr-> CDouble -> CWString-> IO () +foreign import ccall safe "setFloatField" f_setFloatField :: JObjectPtr -> JFieldPtr-> CFloat -> CWString -> IO () +foreign import ccall safe "setObjectField" f_setObjectField :: JObjectPtr -> JFieldPtr -> JObjectPtr -> CWString -> IO () + +foreign import ccall safe "registerCallback" f_registerCallback :: CString -> CString -> CString -> FunPtr CallbackInternal -> IO() + +foreign import ccall "wrapper" wrap :: CallbackInternal -> IO (FunPtr CallbackInternal) + +withJava :: String -> JavaT a -> IO a +withJava = withJava' True + +withJava' :: Bool -> String -> JavaT a -> IO a +withJava' end options f= do + ret<-withCString options (\s->f_start s) + when (ret < 0) (ioError $ userError "could not start JVM") + (a,s)<-runStateT f (JavaCache Map.empty Map.empty Map.empty) + when end (evalStateT endJava s) + return a + +endJava :: JavaT() +endJava = do + jc<-getJavaCache + liftIO $ mapM_ (\ptr->f_freeClass ptr) (Map.elems $ jc_classes jc) + putJavaCache (JavaCache Map.empty Map.empty Map.empty) + liftIO $ f_end + +--withJavaRT :: (JRuntimePtr -> IO (a)) -> JavaT a +--withJavaRT f=do +-- rt<-get +-- r<-liftIO $ f rt +-- return r + +registerCallBackMethod:: (WithJava m) => String -> String -> String -> m (CallbackMapRef) +registerCallBackMethod cls method eventCls =do + jc<-getJavaCache + ior<-liftIO $ newMVar Map.empty + eventW<-liftIO $ wrap (event jc ior ) + liftIO $ withCString cls + (\clsn->withCString method + (\methodn->withCString eventCls + (\eventClsn->f_registerCallback clsn methodn eventClsn eventW))) + return ior + +addCallBack :: (WithJava m) => CallbackMapRef -> Callback -> m(CLong) +addCallBack cmr cb=do + liftIO $ modifyMVar cmr (\m-> do + let index=fromIntegral $ Map.size m + return (Map.insert index cb m,index)) + +findClass :: (WithJava m) => ClassName -> m JClassPtr +findClass name=do + jc<-getJavaCache + let mptr=Map.lookup name (jc_classes jc) + case mptr of + Just ptr->return ptr + Nothing->do + ptr<-liftIO $ withCString name (\s->f_findClass s) + putJavaCache (jc{jc_classes=Map.insert name ptr $ jc_classes jc}) + return ptr + + +withClass :: (WithJava m) => ClassName -> (JClassPtr->m a) -> m a +withClass className f= findClass (className)>>=(\cls->do + when (cls==nullPtr) (liftIO $ ioError $ userError $ printf "class %s not found" className) + f cls) + + +freeClass :: (WithJava m) => ClassName -> m () +freeClass name=do + jc<-getJavaCache + let mptr=Map.lookup name (jc_classes jc) + case mptr of + Just ptr->do + liftIO $ f_freeClass ptr + putJavaCache (jc{jc_classes=Map.delete name $ jc_classes jc}) + Nothing->return () + +findMethod :: (WithJava m) => Method -> m JMethodPtr +findMethod meth=do + jc<-getJavaCache + let mptr=Map.lookup meth (jc_methods jc) + case mptr of + Just ptr->return ptr + Nothing -> do + withClass (m_class meth) (\cls->do + ptr<- liftIO $ withCString (m_name meth) + (\m->withCString (m_signature meth) + (\s->f_findMethod cls m s + )) + putJavaCache (jc{jc_methods=Map.insert meth ptr $ jc_methods jc}) + return ptr) + +findStaticMethod :: (WithJava m) => Method -> m JMethodPtr +findStaticMethod meth=do + jc<-getJavaCache + let mptr=Map.lookup meth (jc_methods jc) + case mptr of + Just ptr->return ptr + Nothing -> do + withClass (m_class meth) (\cls->do + ptr<- liftIO $ withCString (m_name meth) + (\m->withCString (m_signature meth) + (\s->f_findStaticMethod cls m s + )) + putJavaCache (jc{jc_methods=Map.insert meth ptr $ jc_methods jc}) + return ptr) + +withMethod :: (WithJava m) => Method -> (JMethodPtr -> m a) -> m a +withMethod mp f=do + mid<-findMethod mp + when (mid==nullPtr) (liftIO $ ioError $ userError $ printf "method %s not found" $ show mp) + f mid + +withStaticMethod :: (WithJava m) => Method -> (JMethodPtr -> m a) -> m a +withStaticMethod mp f=do + mid<-findStaticMethod mp + when (mid==nullPtr) (liftIO $ ioError $ userError $ printf "static method %s not found" $ show mp) + f mid + +findField :: (WithJava m) => Field -> m JFieldPtr +findField field=do + jc<-getJavaCache + let mptr=Map.lookup field (jc_fields jc) + case mptr of + Just ptr->return ptr + Nothing -> do + withClass (f_class field) (\cls->do + ptr<- liftIO $ withCString (f_name field) + (\m->withCString (f_signature field) + (\s->f_findField cls m s + )) + putJavaCache (jc{jc_fields=Map.insert field ptr $ jc_fields jc}) + return ptr) + +findStaticField :: (WithJava m) => Field -> m JFieldPtr +findStaticField field=do + jc<-getJavaCache + let mptr=Map.lookup field (jc_fields jc) + case mptr of + Just ptr->return ptr + Nothing -> do + withClass (f_class field) (\cls->do + ptr<- liftIO $ withCString (f_name field) + (\m->withCString (f_signature field) + (\s->f_findStaticField cls m s + )) + putJavaCache (jc{jc_fields=Map.insert field ptr $ jc_fields jc}) + return ptr) + +withField :: (WithJava m) => Field -> (JFieldPtr -> m a) -> m a +withField mp f=do + fid<-findField mp + when (fid==nullPtr) (liftIO $ ioError $ userError $ printf "field %s not found" $ show mp) + f fid + +withStaticField :: (WithJava m) => Field -> (JFieldPtr -> m a) -> m a +withStaticField mp f=do + fid<-findStaticField mp + when (fid==nullPtr) (liftIO $ ioError $ userError $ printf "static field %s not found" $ show mp) + f fid + +handleException :: (CWString -> IO a) -> IO a +handleException f=allocaBytes 1000 (\errMsg ->do + ret<-f errMsg + s<-peekCWString errMsg + when (not $ null s) (ioError $ userError s) + return ret + ) + +withObject :: (WithJava m) => (m JObjectPtr) -> (JObjectPtr -> m a) -> m a +withObject f1 f2=do + obj <- f1 + ret <- f2 obj + liftIO $ f_freeObject obj + return (ret) + +newObject :: (WithJava m) => ClassName -> String -> [JValue] -> m (JObjectPtr) +newObject className signature args= withClass (className) (\cls->do + withMethod (Method className "" signature) (\mid-> + liftIO $ withArray args + (\arr-> handleException $ f_newObject cls mid arr))) + +event :: JavaCache -> CallbackMapRef -> CallbackInternal +event jc mvar _ _ index eventObj=do + putStrLn "event" + putStrLn ("listenerEvt:"++(show index)) + mh<-liftIO $ withMVar mvar (\m->do + return $ Map.lookup index m + ) + case mh of + Nothing-> return () + Just h->evalStateT (h eventObj) jc + + +--instance MethodProvider (JClassPtr,String,String) where +-- getMethodID (cls,method,signature)=do +-- withCString method +-- (\m->withCString signature +-- (\s->f_findMethod cls m s)) +-- +--instance MethodProvider (String,String,String) where +-- getMethodID (clsName,method,signature)=do +-- findClass clsName>>=(\cls->do +-- when (cls==nullPtr) (ioError $ userError $ printf "class %s not found" clsName) +-- withCString method +-- (\m->withCString signature +-- (\s->f_findMethod cls m s))) +-- + + + + +voidMethod :: (WithJava m) => JObjectPtr -> Method -> [JValue] -> m () +voidMethod obj m args= + withMethod m (\mid->liftIO $ withArray args (\arr->handleException $ f_callVoidMethod obj mid arr)) + +execMethod :: (HaskellJavaConversion h j,WithJava m) => + (JObjectPtr -> JMethodPtr -> JValuePtr -> CWString-> IO j) + -> JObjectPtr -> Method -> [JValue] -> m h +execMethod f obj m args = javaToHaskell $ withMethod m (\mid->liftIO $ withArray args (\arr->handleException $ f obj mid arr)) + +booleanMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Bool) +booleanMethod obj m args= execMethod f_callBooleanMethod obj m args + +intMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Integer) +intMethod obj m args= execMethod f_callIntMethod obj m args + +charMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Char) +charMethod obj m args= execMethod f_callCharMethod obj m args + +shortMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Int) +shortMethod obj m args= execMethod f_callShortMethod obj m args + +byteMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Int) +byteMethod obj m args= execMethod f_callByteMethod obj m args + +longMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Integer) +longMethod obj m args= execMethod f_callLongMethod obj m args + +floatMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Float) +floatMethod obj m args= execMethod f_callFloatMethod obj m args + +doubleMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (Double) +doubleMethod obj m args= execMethod f_callDoubleMethod obj m args + +objectMethod :: (WithJava m) =>JObjectPtr -> Method -> [JValue] -> m (JObjectPtr) +objectMethod obj m args= execMethod f_callObjectMethod obj m args + +execStaticMethod :: (HaskellJavaConversion h j,WithJava m) => + (JClassPtr -> JMethodPtr -> JValuePtr -> CWString-> IO j) + -> JClassPtr -> Method -> [JValue] -> m h +execStaticMethod f cls m args = javaToHaskell $ withStaticMethod m (\mid->liftIO $ withArray args (\arr->handleException $ f cls mid arr)) + +staticIntMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Integer) +staticIntMethod cls m args= execStaticMethod f_callStaticIntMethod cls m args + +staticBooleanMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Bool) +staticBooleanMethod cls m args= execStaticMethod f_callStaticBooleanMethod cls m args + +staticCharMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Char) +staticCharMethod cls m args= execStaticMethod f_callStaticCharMethod cls m args + +staticShortMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Int) +staticShortMethod cls m args= execStaticMethod f_callStaticShortMethod cls m args + +staticByteMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Int) +staticByteMethod cls m args= execStaticMethod f_callStaticByteMethod cls m args + +staticLongMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Integer) +staticLongMethod cls m args= execStaticMethod f_callStaticLongMethod cls m args + +staticFloatMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Float) +staticFloatMethod cls m args= execStaticMethod f_callStaticFloatMethod cls m args + +staticDoubleMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (Double) +staticDoubleMethod cls m args= execStaticMethod f_callStaticDoubleMethod cls m args + +staticObjectMethod :: (WithJava m) =>JClassPtr -> Method -> [JValue] -> m (JObjectPtr) +staticObjectMethod cls m args= execStaticMethod f_callStaticObjectMethod cls m args + +getStaticField :: (HaskellJavaConversion h j,WithJava m) => + (JClassPtr -> JFieldPtr -> CWString-> IO j) + -> JClassPtr -> Field -> m h +getStaticField f cls fi = javaToHaskell $ withStaticField fi (\fid->liftIO $ handleException $ f cls fid) + +getStaticIntField :: (WithJava m) =>JClassPtr -> Field -> m (Integer) +getStaticIntField = getStaticField f_getStaticIntField + +getStaticBooleanField :: (WithJava m) =>JClassPtr -> Field -> m (Bool) +getStaticBooleanField = getStaticField f_getStaticBooleanField + +getStaticCharField :: (WithJava m) =>JClassPtr -> Field -> m (Char) +getStaticCharField = getStaticField f_getStaticCharField + +getStaticShortField :: (WithJava m) =>JClassPtr -> Field -> m (Int) +getStaticShortField = getStaticField f_getStaticShortField + +getStaticByteField :: (WithJava m) =>JClassPtr -> Field -> m (Int) +getStaticByteField= getStaticField f_getStaticByteField + +getStaticLongField :: (WithJava m) =>JClassPtr -> Field -> m (Integer) +getStaticLongField = getStaticField f_getStaticLongField + +getStaticDoubleField :: (WithJava m) =>JClassPtr -> Field -> m (Double) +getStaticDoubleField= getStaticField f_getStaticDoubleField + +getStaticFloatField :: (WithJava m) =>JClassPtr -> Field -> m (Float) +getStaticFloatField= getStaticField f_getStaticFloatField + +getStaticObjectField :: (WithJava m) =>JClassPtr -> Field -> m (JObjectPtr) +getStaticObjectField= getStaticField f_getStaticObjectField + +setStaticField :: (HaskellJavaConversion h j,WithJava m) => + (JClassPtr -> JFieldPtr -> j -> CWString -> IO ()) + -> JClassPtr -> Field -> h -> m () +setStaticField f cls fi v= withStaticField fi (\fid->liftIO $ handleException $ f cls fid $ fromHaskell v) + +setStaticIntField :: (WithJava m) =>JClassPtr -> Field -> Integer -> m () +setStaticIntField = setStaticField f_setStaticIntField + +setStaticBooleanField :: (WithJava m) =>JClassPtr -> Field -> Bool -> m () +setStaticBooleanField = setStaticField f_setStaticBooleanField + +setStaticCharField :: (WithJava m) =>JClassPtr -> Field -> Char -> m () +setStaticCharField = setStaticField f_setStaticCharField + +setStaticShortField :: (WithJava m) =>JClassPtr -> Field -> Int -> m () +setStaticShortField = setStaticField f_setStaticShortField + +setStaticByteField :: (WithJava m) =>JClassPtr -> Field -> Int -> m () +setStaticByteField = setStaticField f_setStaticByteField + +setStaticLongField :: (WithJava m) =>JClassPtr -> Field -> Integer -> m () +setStaticLongField = setStaticField f_setStaticLongField + +setStaticDoubleField :: (WithJava m) =>JClassPtr -> Field -> Double -> m () +setStaticDoubleField = setStaticField f_setStaticDoubleField + +setStaticFloatField :: (WithJava m) =>JClassPtr -> Field -> Float -> m () +setStaticFloatField = setStaticField f_setStaticFloatField + +setStaticObjectField :: (WithJava m) =>JClassPtr -> Field -> JObjectPtr -> m () +setStaticObjectField = setStaticField f_setStaticObjectField + +getField :: (HaskellJavaConversion h j,WithJava m) => + (JObjectPtr -> JFieldPtr -> CWString-> IO j) + -> JObjectPtr -> Field -> m h +getField f cls fi = javaToHaskell $ withField fi (\fid->liftIO $ handleException $ f cls fid) + +getIntField :: (WithJava m) =>JObjectPtr -> Field -> m (Integer) +getIntField = getField f_getIntField + +getBooleanField :: (WithJava m) =>JObjectPtr -> Field -> m (Bool) +getBooleanField = getField f_getBooleanField + +getCharField :: (WithJava m) =>JObjectPtr -> Field -> m (Char) +getCharField = getField f_getCharField + +getShortField :: (WithJava m) =>JObjectPtr -> Field -> m (Int) +getShortField = getField f_getShortField + +getByteField :: (WithJava m) =>JObjectPtr -> Field -> m (Int) +getByteField= getField f_getByteField + +getLongField :: (WithJava m) =>JObjectPtr -> Field -> m (Integer) +getLongField = getField f_getLongField + +getDoubleField :: (WithJava m) =>JObjectPtr -> Field -> m (Double) +getDoubleField= getField f_getDoubleField + +getFloatField :: (WithJava m) =>JObjectPtr -> Field -> m (Float) +getFloatField= getField f_getFloatField + +getObjectField :: (WithJava m) =>JObjectPtr -> Field -> m (JObjectPtr) +getObjectField= getField f_getObjectField + +setField :: (HaskellJavaConversion h j,WithJava m) => + (JObjectPtr -> JFieldPtr -> j -> CWString -> IO ()) + -> JObjectPtr -> Field -> h -> m () +setField f cls fi v= withField fi (\fid->liftIO $ handleException $ f cls fid $ fromHaskell v) + +setIntField :: (WithJava m) =>JObjectPtr -> Field -> Integer -> m () +setIntField = setField f_setIntField + +setBooleanField :: (WithJava m) =>JObjectPtr -> Field -> Bool -> m () +setBooleanField = setField f_setBooleanField + +setCharField :: (WithJava m) =>JObjectPtr -> Field -> Char -> m () +setCharField = setField f_setCharField + +setShortField :: (WithJava m) =>JObjectPtr -> Field -> Int -> m () +setShortField = setField f_setShortField + +setByteField :: (WithJava m) =>JObjectPtr -> Field -> Int -> m () +setByteField = setField f_setByteField + +setLongField :: (WithJava m) =>JObjectPtr -> Field -> Integer -> m () +setLongField = setField f_setLongField + +setDoubleField :: (WithJava m) =>JObjectPtr -> Field -> Double -> m () +setDoubleField = setField f_setDoubleField + +setFloatField :: (WithJava m) =>JObjectPtr -> Field -> Float -> m () +setFloatField = setField f_setFloatField + +setObjectField :: (WithJava m) =>JObjectPtr -> Field -> JObjectPtr -> m () +setObjectField = setField f_setObjectField + + + +toJString :: (MonadIO m) => String -> m (JObjectPtr) +toJString s= liftIO $ withCWString s (\cs->handleException $ f_newString cs (fromIntegral $ length s)) diff --git a/src/Language/Java/JVM/Generator.hs b/src/Language/Java/JVM/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/Generator.hs @@ -0,0 +1,141 @@ + +module Language.Java.JVM.Generator where + +import Language.Java.JVM.JavapParser +import Language.Java.JVM.SignatureParser + +import Control.Monad.Identity +import Control.Monad.State + +import Data.Char (toUpper) +import Data.List (foldl') +import qualified Data.Set as Set + +import Language.Haskell.Exts.Syntax +import Text.Parsec +import System.Info +import System.FilePath +import System.Process + + +addExeExtension :: FilePath -> String +addExeExtension fn= case os of + "mingw32"->addExtension fn "exe" + "cygwin32"->addExtension fn "exe" + "win32"->addExtension fn "exe" + _->fn + +runJavap :: FilePath -> String -> IO(String) +runJavap javaHome className=do + let javapPath=javaHome "bin" (addExeExtension "javap") + s<-readProcess javapPath ["-s",className] "" + let l=lines s + case l of + (_:xs)-> return $ unlines xs + _ -> return "" + +parseClass :: FilePath -> String -> IO (Either ParseError TypeDecl) +parseClass javaHome className=do + contents<-runJavap javaHome className + return $ parseTypeDecl contents + +generate :: TypeDecl -> (Module,FilePath) +generate td=let + cls=td_name td + moduleName=map toMod (zip [0..] cls) + fp=addExtension moduleName "hs" + decls=concat $ runIdentity $ evalStateT (mapM (generateDecl cls) (td_decls td)) ((SrcLoc fp 6 1),Set.empty) + impTypes=ImportDecl (SrcLoc fp 3 1) (ModuleName "Language.Java.JVM.Types") False False Nothing Nothing Nothing + impAPI=ImportDecl (SrcLoc fp 3 1) (ModuleName "Language.Java.JVM.API") False False Nothing Nothing Nothing + in (Module (SrcLoc fp 2 1) (ModuleName ("Language.Java.JVM.Bindings."++moduleName)) [LanguagePragma (SrcLoc fp 1 1) [Ident "RankNTypes"]] Nothing Nothing [impTypes,impAPI] decls,fp) + where + toMod (_,'/')='_' + toMod (0,a)=toUpper a + toMod (_,a)=a + +generateDecl :: String -> JDecl -> SrcLocT [Decl] +generateDecl cls (JMethodDecl name signature static)=do + slTyp<-srcLoc + slFun<-srcLoc + id<-identName name + let + Right (JSignature params ret)=parseSignature signature + (exp,ret')=if name=="" + then + (App (App (Var (UnQual (Ident "newObject"))) (Lit $ String cls)) (Lit $ String signature),Just "JObj") + else + let + methoddef=App (App (App (Con (UnQual (Ident "Method"))) (Lit $ String cls)) (Lit $ String name)) (Lit $ String signature) + methodInvocation=Var (UnQual (Ident $ wrapperToMethod ret)) + obj=Var (UnQual (Ident "obj")) + in (App (App methodInvocation obj) methoddef,ret) + pats=zipWith (\_ idx->PVar $ Ident ("p"++(show idx))) params [0..] + patsWithObj=if name /= "" && (not static) + then ((PVar $ Ident "obj") : pats) + else pats + parms=zipWith (\w idx->App (Var $ UnQual $ Ident w) $ cast w (Var $ UnQual $ Ident ("p"++(show idx)))) params [0..] + rhs=UnGuardedRhs $ App exp $ List parms + m0=Match slFun (Ident id) patsWithObj Nothing rhs (BDecls []) + retType=TyApp (TyVar $ Ident "m") (TyVar $ Ident $ wrapperToUnwrapped ret') + paramType=foldl' (\t p->(TyFun (TyVar $ Ident $ wrapperToUnwrapped $ Just p) t)) retType params + objType=if name=="" + then paramType + else (TyFun (TyVar $ Ident "JObjectPtr") paramType) + typ=TyForall Nothing [ClassA (UnQual $ Ident "WithJava") [(TyVar $ Ident "m")]] objType + sig=TypeSig slFun [Ident id] typ + return $ [sig,FunBind [m0]] +generateDecl cls (JFieldDecl name signature static)=undefined + +type SrcLocT=StateT GenState Identity + +type GenState=(SrcLoc,Set.Set String) + +srcLoc :: SrcLocT SrcLoc +srcLoc= do + sl<-gets fst + modify (\((SrcLoc fp l c),g)->(SrcLoc fp (l+1) c,g)) + return sl + +identName:: String -> SrcLocT String +identName n=do + names<-gets snd + let + n'=if n=="" + then "new" + else n + possibleNames=[n'] ++ (map (\idx->(n')++(show idx)) [1..]) + okNames=filter (\pn->Set.notMember pn names) possibleNames + firstOK=head okNames + modify (\(s,ns)->(s,Set.insert firstOK ns)) + return firstOK + +cast :: String -> Exp -> Exp +cast "JLong"= App (Var $ UnQual $ Ident "fromIntegral") +cast "JInt"= App (Var $ UnQual $ Ident "fromIntegral") +cast _=id + +wrapperToUnwrapped :: Maybe String -> String +wrapperToUnwrapped (Just "JObj")="JObjectPtr" +wrapperToUnwrapped (Just "JInt")="Integer" +wrapperToUnwrapped (Just "JBool")="Bool" +wrapperToUnwrapped (Just "JByte")="Int" +wrapperToUnwrapped (Just "JChar")="Char" +wrapperToUnwrapped (Just "JShort")="Int" +wrapperToUnwrapped (Just "JLong")="Integer" +wrapperToUnwrapped (Just "JFloat")="Float" +wrapperToUnwrapped (Just "JDouble")="Double" +wrapperToUnwrapped Nothing="()" +wrapperToUnwrapped (Just a)=error ("undefined wrapper"++a) + +wrapperToMethod :: Maybe String -> String +wrapperToMethod (Just "JObj")="objectMethod" +wrapperToMethod (Just "JInt")="intMethod" +wrapperToMethod (Just "JBool")="booleanMethod" +wrapperToMethod (Just "JByte")="byteMethod" +wrapperToMethod (Just "JChar")="charMethod" +wrapperToMethod (Just "JShort")="shortMethod" +wrapperToMethod (Just "JLong")="longMethod" +wrapperToMethod (Just "JFloat")="floatMethod" +wrapperToMethod (Just "JDouble")="doubleMethod" +wrapperToMethod Nothing="voidMethod" +wrapperToMethod (Just a)=error ("undefined wrapper"++a) diff --git a/src/Language/Java/JVM/JavapParser.hs b/src/Language/Java/JVM/JavapParser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/JavapParser.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RankNTypes #-} + +module Language.Java.JVM.JavapParser where + +import Language.Java.JVM.Types + +import Control.Monad +import Data.Functor.Identity +import Data.List +import Data.Maybe + +import Text.Parsec +import qualified Text.Parsec.Token as P +import Text.Parsec.Language (javaStyle) + + +data TypeDecl=TypeDecl { + td_name::ClassName + ,td_supers::[ClassName] + ,td_decls::[JDecl] + } + deriving (Show,Read,Eq,Ord) + +data JDecl=JMethodDecl { + d_name::String + ,d_signature::String + ,d_static::Bool + } + | JFieldDecl { + d_name::String + ,d_signature::String + ,d_static::Bool + } + deriving (Show,Read,Eq,Ord) + +parseTypeDecl :: String -> Either ParseError TypeDecl +parseTypeDecl contents= parse typeDecl "unknown" contents + +typeDecl ::ParsecT String u Identity TypeDecl +typeDecl=do + modifiers + choice [symbol "class",symbol "interface"] + name<-className + extends<-optionMaybe (do + symbol "extends" + classList + ) + implements<-optionMaybe (do + symbol "implements" + classList + ) + decls<-braces (do + decls<-many $ decl + return $ catMaybes decls) + return $ TypeDecl name (concat $ catMaybes [extends,implements]) decls + +decl :: ParsecT String u Identity (Maybe JDecl) +decl = do + sta<-static + choice [(do + staticBlock + return Nothing) + ,(do + className + (name,meth)<-choice [(do + parens (classList0) + return ("",True) + ), + (do + name <-identifier + p<-optionMaybe $ parens (classList0) + return (name,isJust p) + ) + ] + when meth (optional (do + symbol "throws" + classList + )) + semi + sign<-signature + return $ if meth + then Just $ JMethodDecl name sign sta + else Just $ JFieldDecl name sign sta + )] + +--methodDecl :: ParsecT String u Identity (Bool -> Decl) +--methodDecl=do +-- className +-- name<-choice [(do +-- parens (classList0) +-- return "" +-- ), +-- (do +-- name <-identifier +-- parens (classList0) +-- return name +-- ) +-- ] +-- optional (do +-- symbol "throws" +-- classList +-- ) +-- semi +-- sign<-signature +-- return $ MethodDecl name sign +-- +--fieldDecl :: ParsecT String u Identity (Bool -> Decl) +--fieldDecl=do +-- className +-- name<-identifier +-- semi +-- sign<-signature +-- return $ FieldDecl name sign + +signature :: ParsecT String u Identity String +signature=do + symbol "Signature" + colon + manyTill anyToken (try (newline)) + +staticBlock :: ParsecT String u Identity () +staticBlock=do + braces whiteSpace + semi + signature + return () + +classList :: ParsecT String u Identity [ClassName] +classList=sepBy1 className comma + +classList0 :: ParsecT String u Identity [ClassName] +classList0=sepBy className comma + +className ::ParsecT String u Identity ClassName +className = do + names<-sepBy1 identifier dot + optionMaybe $ brackets whiteSpace + return $ intercalate "/" names + +static :: ParsecT String u Identity Bool +static = do + mds<-modifiers + return $ elem "static" mds + +modifiers ::ParsecT String u Identity [String] +modifiers = many $ try $ choice [ + try $ symbol "public" + ,try $ symbol "protected" + ,symbol "private" + ,symbol "static" + ,symbol "volatile" + ,symbol "transient" + ,symbol "final" + ,symbol "native"] + +lexer ::P.GenTokenParser String u Identity +lexer=P.makeTokenParser javaStyle + +parens :: ParsecT String u Identity a -> ParsecT String u Identity a +parens = P.parens lexer +braces :: ParsecT String u Identity a -> ParsecT String u Identity a +braces = P.braces lexer +brackets :: ParsecT String u Identity a -> ParsecT String u Identity a +brackets = P.brackets lexer + +identifier :: ParsecT String u Identity String +identifier = P.identifier lexer + +symbol :: String -> ParsecT String u Identity String +symbol = P.symbol lexer + +dot :: ParsecT String u Identity String +dot = P.dot lexer + +comma :: ParsecT String u Identity String +comma = P.comma lexer + +colon :: ParsecT String u Identity String +colon = P.colon lexer + +semi :: ParsecT String u Identity String +semi = P.semi lexer + +whiteSpace :: ParsecT String u Identity () +whiteSpace = P.whiteSpace lexer diff --git a/src/Language/Java/JVM/SignatureParser.hs b/src/Language/Java/JVM/SignatureParser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/SignatureParser.hs @@ -0,0 +1,61 @@ + +module Language.Java.JVM.SignatureParser where + +import Data.Functor.Identity +import Text.Parsec + + +data JSignature=JSignature [String] (Maybe String) + deriving (Read,Show,Eq,Ord) + +parseSignature :: String -> Either ParseError JSignature +parseSignature contents= parse signature "unknown" contents + +signature :: ParsecT String u Identity JSignature +signature = do + char '(' + params<-many typeSignature + char ')' + ret<-choice [(do + t<-typeSignature + return $ Just t),(do + char 'V' + return Nothing)] + return $ JSignature params ret + +typeSignature :: ParsecT String u Identity String +typeSignature = choice [(do + char '[' + ts<-typeSignature + return "JObj" + --return (ts++"[]") + + ),(do + char 'L' + manyTill (anyChar) (try $ char ';') + return "JObj") + ,(do + char 'I' + return "JInt") + ,(do + char 'S' + return "JShort") + ,(do + char 'Z' + return "JBool") + ,(do + char 'B' + return "JByte") + ,(do + char 'D' + return "JDouble") + ,(do + char 'F' + return "JFloat") + ,(do + char 'C' + return "JChar") + ,(do + char 'J' + return "JLong") + ] diff --git a/src/Language/Java/JVM/Types.hs b/src/Language/Java/JVM/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/Types.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, RankNTypes, ImpredicativeTypes, MultiParamTypeClasses #-} + +module Language.Java.JVM.Types where + +import qualified Data.Map as Map +import Foreign.C +import Foreign.Ptr +import Foreign.Storable +import Data.Map (Map) +import Control.Concurrent.MVar +import Control.Monad.State + +data JObject +type JObjectPtr=Ptr JObject +data JClass +type JClassPtr=Ptr JClass +data JMethod +type JMethodPtr=Ptr JMethod +data JField +type JFieldPtr=Ptr JField +--data JRuntime +--type JRuntimePtr=Ptr JRuntime + +newtype TypedJObjectPtr a=TypedJObjectPtr JObjectPtr + deriving (Eq,Show) + +data JEnv +type JEnvPtr=Ptr JEnv + +type CallbackInternal=(JEnvPtr -> JObjectPtr -> CLong -> JObjectPtr -> IO()) + +type Callback = (JObjectPtr -> JavaT ()) + +type CallbackMap = Map.Map CLong Callback +type CallbackMapRef =MVar CallbackMap + +data JValue=JObj JObjectPtr + | JInt CLong + | JBool CUChar + | JByte CChar + | JChar CUShort + | JShort CShort + | JLong CLong + | JFloat CFloat + | JDouble CDouble + +type JValuePtr=Ptr JValue + +instance Storable JValue where + sizeOf _= 8 + alignment _=alignment (undefined :: CDouble) + poke p (JObj l)= poke (castPtr p) l + poke p (JInt i)= poke (castPtr p) i + poke p (JBool z)= poke (castPtr p) z + poke p (JByte b)= poke (castPtr p) b + poke p (JChar c)= poke (castPtr p) c + poke p (JShort s)= poke (castPtr p) s + poke p (JLong j)= poke (castPtr p) j + poke p (JFloat f)= poke (castPtr p) f + poke p (JDouble d)= poke (castPtr p) d + peek=error "undefined peek" + +--class MethodProvider a where +-- getMethodID :: a -> IO (JMethodPtr) + +--instance MethodProvider JMethodPtr where +-- getMethodID=return + +type ClassName = String + +data Method = Method { + m_class::ClassName + ,m_name:: String + ,m_signature:: String + } + deriving (Read,Show,Eq,Ord) + +data Field= Field { + f_class::ClassName + ,f_name:: String + ,f_signature:: String + } + deriving (Read,Show,Eq,Ord) + +type ClassCache=Map ClassName JClassPtr +type MethodCache=Map Method JMethodPtr +type FieldCache=Map Field JFieldPtr + +data JavaCache=JavaCache { + jc_classes::ClassCache + ,jc_methods::MethodCache + ,jc_fields::FieldCache + } + +type JavaT =StateT JavaCache IO + +class (Monad m, MonadIO m) => WithJava m where + getJavaCache :: m JavaCache + putJavaCache :: JavaCache -> m() + +instance WithJava JavaT where + getJavaCache = do + rt<-get + return rt + putJavaCache=put + +javaToHaskell :: (HaskellJavaConversion h j,WithJava m)=> m j -> m h +javaToHaskell = liftM toHaskell + +haskellToJava :: (HaskellJavaConversion h j,WithJava m)=> m h -> m j +haskellToJava = liftM fromHaskell + +class HaskellJavaConversion h j where + toHaskell :: j -> h + fromHaskell :: h -> j + +instance HaskellJavaConversion Float CFloat where + toHaskell = realToFrac + fromHaskell = realToFrac + +instance HaskellJavaConversion Double CDouble where + toHaskell = realToFrac + fromHaskell = realToFrac + +instance HaskellJavaConversion Integer CLong where + toHaskell = fromIntegral + fromHaskell = fromIntegral + +instance HaskellJavaConversion Int CChar where + toHaskell = fromIntegral + fromHaskell = fromIntegral + +instance HaskellJavaConversion Int CShort where + toHaskell = fromIntegral + fromHaskell = fromIntegral + +instance HaskellJavaConversion Bool CUChar where + toHaskell = (0 /=) + fromHaskell True = 1 + fromHaskell False = 0 + +instance HaskellJavaConversion Char CUShort where + toHaskell = toEnum . fromIntegral + fromHaskell = fromIntegral . fromEnum + +instance HaskellJavaConversion JObjectPtr JObjectPtr where + toHaskell = id + fromHaskell = id + diff --git a/src/Language/Java/JVM/hjvm.c b/src/Language/Java/JVM/hjvm.c new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/hjvm.c @@ -0,0 +1,655 @@ +#include +#include +#include +#include + +#include "hjvm.h" + +/*eventCallback *eventCb; + +void event(JNIEnv *env, jobject listener,jint index,jobject event){ + eventCb(index,event); +}*/ + +JavaVM *getJVM(){ + JavaVM *jvm; + jsize vmnb; + JNI_GetCreatedJavaVMs(&jvm,1,&vmnb); + return jvm; +} + +JNIEnv* getEnv(JavaVM *jvm){ + JNIEnv *env; + (*jvm)->AttachCurrentThread(jvm,(void**)&env,NULL); + return env; +} + +jint start(char* classpath){ + jint res; + JNIEnv *env; + JavaVM *jvm; + JavaVMInitArgs vm_args; + JavaVMOption options[1]; + jsize vmnb; + //runtime rt=(runtime)malloc(sizeof(runtime*)); + //jclass nativeListener; + res = JNI_GetCreatedJavaVMs(&jvm,1,&vmnb); + if (res<0){ + return res; + } + if (vmnb<1){ + + options[0].optionString =classpath; + vm_args.version = JNI_VERSION_1_4; //0x00010002; + vm_args.options = options; + vm_args.nOptions = 1; + vm_args.ignoreUnrecognized = JNI_TRUE; + /* Create the Java VM */ + return JNI_CreateJavaVM(&jvm, (void**)&env, &vm_args); + } +// if (res<0){ +// return NULL; +// } + // rt->env=env; + // rt->jvm=jvm; + // eventCb=f; + + // nativeListener=findClass(rt,"Language/Java/SWT/NativeListener"); + // (*env)->RegisterNatives(env,nativeListener, methods, 1); + + + return 0; +} + +void registerCallback(const char *clsName,const char *methodName,const char *eventClsName,eventCallback f){ + int length=3+(strlen(eventClsName))+3; + char *signature; + jclass cls; + JNINativeMethod methods[1] ; + JNINativeMethod* m=malloc(sizeof(JNINativeMethod)); + char *methodcpy=(char *)malloc(sizeof(char) * (strlen(methodName)+1)); + JNIEnv *env=getEnv(getJVM()); + cls=findClass(clsName); + + methodcpy= + strcpy(methodcpy,methodName); + + signature = (char *)malloc(sizeof(char) * (length+1)); + strcpy(signature,"(IL"); + strcat(signature,eventClsName); + strcat(signature,";)V"); + + m->name= methodcpy; + m->signature= signature; + m->fnPtr= f; + methods[0]=*m; + + (*env)->RegisterNatives(env, cls,methods,1); + + free(m); + free(methodcpy); + free(signature); +} + +void end(){ + JavaVM* jvm=getJVM(); + (*jvm)->DestroyJavaVM(jvm); +// free(rt->env); +// free(rt); +} + +jclass findClass(const char *name){ + JNIEnv *env=getEnv(getJVM()); + jclass local=(*env)->FindClass(env, name); + jclass global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +void freeClass(jclass global){ + JNIEnv *env=getEnv(getJVM()); + (*env)->DeleteGlobalRef(env, global); +} + +void freeObject(jobject global){ + JNIEnv *env=getEnv(getJVM()); + (*env)->DeleteGlobalRef(env, global); +} + +jmethodID findMethod(const jclass cls,const char *method,const char *signature){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + mid=(*env)->GetMethodID(env, cls, method, + signature); + (*env)->ExceptionClear(env); + return mid; +} + +jfieldID findField(const jclass cls,const char *name,const char *signature){ + JNIEnv *env=getEnv(getJVM()); + jfieldID fid; + fid=(*env)->GetFieldID(env, cls, name, + signature); + (*env)->ExceptionClear(env); + return fid; +} + +jfieldID findStaticField(const jclass cls,const char *name,const char *signature){ + JNIEnv *env=getEnv(getJVM()); + jfieldID fid; + fid=(*env)->GetStaticFieldID(env, cls, name, + signature); + (*env)->ExceptionClear(env); + return fid; +} + +jmethodID findStaticMethod(const jclass cls,const char *method,const char *signature){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + mid=(*env)->GetStaticMethodID(env, cls, method, + signature); + (*env)->ExceptionClear(env); + return mid; +} + +void handleException(JNIEnv *env,jchar *error){ + jclass cls; + jmethodID mid; + jvalue args[0]; + jobject msgO; + jthrowable exc = (*env)->ExceptionOccurred(env); + jboolean isCopy; + const jchar* msg; + if (exc) { + cls=findClass("java/lang/Throwable"); + mid=findMethod(cls,"getLocalizedMessage","()Ljava/lang/String;"); + msgO=(*env)->CallObjectMethodA (env,exc,mid,args); + msg=(*env)->GetStringChars(env,msgO,&isCopy); + while(*msg != 0) { + *error++ = *msg++; + } + *error =0; + (*env)->ExceptionClear(env); + } else { + *error=0; + } +} + +jobject newObject(const jclass cls, const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + if (cls == NULL || method== NULL) { + return NULL; + } + jobject local=(*env)->NewObjectA(env,cls,method,args); + handleException(env,error); + jobject global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + + +/*jmethodID getMethodID(JNIEnv *env,const jobject obj,const char *method,const char *signature){ + jclass cls; + jmethodID mid; + if (obj==NULL){ + return NULL; + } + cls=(*env)->GetObjectClass(env, obj); + if (cls==NULL){ + return NULL; + } + mid = (*env)->GetMethodID(env, cls, method, + signature); + return mid; +}*/ + +jint callIntMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jint ret=(*env)-> CallIntMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jchar callCharMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jchar ret=(*env)-> CallCharMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jshort callShortMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + jshort ret=(*env)-> CallShortMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jbyte callByteMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + jbyte ret=(*env)-> CallByteMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jlong callLongMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jlong ret=(*env)-> CallLongMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jfloat callFloatMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jfloat ret=(*env)-> CallFloatMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jdouble callDoubleMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jdouble ret=(*env)-> CallDoubleMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +jboolean callBooleanMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jboolean ret=(*env)-> CallBooleanMethodA (env,obj,method,args); + handleException(env,error); + return ret; +} + +void callVoidMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> CallVoidMethodA (env,obj,method,args); + handleException(env,error); +} + +jobject callObjectMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jobject local=(*env)-> CallObjectMethodA (env,obj,method,args); + handleException(env,error); + jobject global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +jint callStaticIntMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jint ret=(*env)-> CallStaticIntMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jchar callStaticCharMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jchar ret=(*env)-> CallStaticCharMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jshort callStaticShortMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + jshort ret=(*env)-> CallStaticShortMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jbyte callStaticByteMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jmethodID mid; + jbyte ret=(*env)-> CallStaticByteMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jlong callStaticLongMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jlong ret=(*env)-> CallStaticLongMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jfloat callStaticFloatMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jfloat ret=(*env)-> CallStaticFloatMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jdouble callStaticDoubleMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jdouble ret=(*env)-> CallStaticDoubleMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +jboolean callStaticBooleanMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jboolean ret=(*env)-> CallStaticBooleanMethodA (env,cls,method,args); + handleException(env,error); + return ret; +} + +void callStaticVoidMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> CallStaticVoidMethodA (env,cls,method,args); + handleException(env,error); +} + +jobject callStaticObjectMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jobject local=(*env)-> CallStaticObjectMethodA (env,cls,method,args); + handleException(env,error); + jobject global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +jstring newString(const jchar *unicode, jsize len,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jstring local=(*env)->NewString(env,unicode,len); + handleException(env,error); + jstring global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +jint getStaticIntField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jint ret=(*env)-> GetStaticIntField (env,cls,field); + handleException(env,error); + return ret; +} + +jboolean getStaticBooleanField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jboolean ret=(*env)-> GetStaticBooleanField (env,cls,field); + handleException(env,error); + return ret; +} + +jchar getStaticCharField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jchar ret=(*env)-> GetStaticCharField (env,cls,field); + handleException(env,error); + return ret; +} + +jshort getStaticShortField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jshort ret=(*env)-> GetStaticShortField (env,cls,field); + handleException(env,error); + return ret; +} + +jbyte getStaticByteField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jbyte ret=(*env)-> GetStaticByteField (env,cls,field); + handleException(env,error); + return ret; +} + +jlong getStaticLongField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jlong ret=(*env)-> GetStaticLongField (env,cls,field); + handleException(env,error); + return ret; +} + +jdouble getStaticDoubleField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jdouble ret=(*env)-> GetStaticDoubleField (env,cls,field); + handleException(env,error); + return ret; +} + +jfloat getStaticFloatField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jfloat ret=(*env)-> GetStaticFloatField (env,cls,field); + handleException(env,error); + return ret; +} + +jobject getStaticObjectField(const jclass cls,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jobject local=(*env)-> GetStaticObjectField (env,cls,field); + handleException(env,error); + jobject global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +void setStaticIntField(const jclass cls,const jfieldID field,jint val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticIntField (env,cls,field,val); + handleException(env,error); +} + +void setStaticBooleanField(const jclass cls,const jfieldID field,jboolean val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticBooleanField (env,cls,field,val); + handleException(env,error); +} + +void setStaticCharField(const jclass cls,const jfieldID field,jchar val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticCharField (env,cls,field,val); + handleException(env,error); +} + +void setStaticShortField(const jclass cls,const jfieldID field,jshort val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticShortField (env,cls,field,val); + handleException(env,error); +} + +void setStaticByteField(const jclass cls,const jfieldID field,jbyte val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticByteField (env,cls,field,val); + handleException(env,error); +} + +void setStaticLongField(const jclass cls,const jfieldID field,jlong val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticLongField (env,cls,field,val); + handleException(env,error); +} + +void setStaticDoubleField(const jclass cls,const jfieldID field,jdouble val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticDoubleField (env,cls,field,val); + handleException(env,error); +} + +void setStaticFloatField(const jclass cls,const jfieldID field,jfloat val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticFloatField (env,cls,field,val); + handleException(env,error); +} + +void setStaticObjectField(const jclass cls,const jfieldID field,jobject val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetStaticObjectField (env,cls,field,val); + handleException(env,error); +} + +jint getIntField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jint ret=(*env)-> GetIntField (env,obj,field); + handleException(env,error); + return ret; +} + +jboolean getBooleanField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jboolean ret=(*env)-> GetBooleanField (env,obj,field); + handleException(env,error); + return ret; +} + +jchar getCharField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jchar ret=(*env)-> GetCharField (env,obj,field); + handleException(env,error); + return ret; +} + +jshort getShortField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jshort ret=(*env)-> GetShortField (env,obj,field); + handleException(env,error); + return ret; +} + +jbyte getByteField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jbyte ret=(*env)-> GetByteField (env,obj,field); + handleException(env,error); + return ret; +} + +jlong getLongField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jlong ret=(*env)-> GetLongField (env,obj,field); + handleException(env,error); + return ret; +} + +jdouble getDoubleField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jdouble ret=(*env)-> GetDoubleField (env,obj,field); + handleException(env,error); + return ret; +} + +jfloat getFloatField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jfloat ret=(*env)-> GetFloatField (env,obj,field); + handleException(env,error); + return ret; +} + +jobject getObjectField(const jobject obj,const jfieldID field,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + jobject local=(*env)-> GetObjectField (env,obj,field); + handleException(env,error); + jobject global=(*env)->NewGlobalRef(env, local); + (*env)->DeleteLocalRef(env, local); + return global; +} + +void setIntField(const jobject obj,const jfieldID field,jint val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetIntField (env,obj,field,val); + handleException(env,error); +} + +void setBooleanField(const jobject obj,const jfieldID field,jboolean val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetBooleanField (env,obj,field,val); + handleException(env,error); +} + +void setCharField(const jobject obj,const jfieldID field,jchar val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetCharField (env,obj,field,val); + handleException(env,error); +} + +void setShortField(const jobject obj,const jfieldID field,jshort val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetShortField (env,obj,field,val); + handleException(env,error); +} + +void setByteField(const jobject obj,const jfieldID field,jbyte val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetByteField (env,obj,field,val); + handleException(env,error); +} + +void setLongField(const jobject obj,const jfieldID field,jlong val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetLongField (env,obj,field,val); + handleException(env,error); +} + +void setDoubleField(const jobject obj,const jfieldID field,jdouble val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetDoubleField (env,obj,field,val); + handleException(env,error); +} + +void setFloatField(const jobject obj,const jfieldID field,jfloat val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetFloatField (env,obj,field,val); + handleException(env,error); +} + +void setObjectField(const jobject obj,const jfieldID field,jobject val,jchar *error){ + JNIEnv *env=getEnv(getJVM()); + (*env)-> SetObjectField (env,obj,field,val); + handleException(env,error); +} + + +/* +int test(int jvmid){ + jclass cls; + jmethodID mid; + jstring jstr; + jclass stringClass; + jobjectArray args; + + cls = (*env)->FindClass(env, "Prog"); + if (cls == NULL) { + return -1; + } + + mid = (*env)->GetStaticMethodID(env, cls, "main", + "([Ljava/lang/String;)V"); + if (mid == NULL) { + return -2; + } + jstr = (*env)->NewStringUTF(env, "from C and Haskell!"); + if (jstr == NULL) { + return -3; + } + stringClass = (*env)->FindClass(env, "java/lang/String"); + args = (*env)->NewObjectArray(env, 1, stringClass, jstr); + if (args == NULL) { + return -4; + } + (*env)->CallStaticVoidMethod(env, cls, mid, args); + return 0; +} + +long create(){ + jclass cls; + jmethodID mid; + jobject obj; + jint i; + cls = (*env)->FindClass(env, "Prog"); + if (cls == NULL) { + return -1; + } + mid = (*env)->GetMethodID(env, cls, "", + "()V"); + if (mid == NULL){ + return -2; + } + obj = (*env)->NewObject(env,cls,mid); + mid = (*env)->GetMethodID(env, cls, "getMethod", + "()I"); + if (mid == NULL){ + return -3; + } + i = (*env)-> CallIntMethod (env,obj,mid); + return i; + +}*/ + diff --git a/src/Language/Java/JVM/hjvm.h b/src/Language/Java/JVM/hjvm.h new file mode 100644 --- /dev/null +++ b/src/Language/Java/JVM/hjvm.h @@ -0,0 +1,94 @@ +#include + +#ifndef HJVM_H +#define HJVM_H + +typedef void (*eventCallback)(JNIEnv *env, jobject listener,jint index,jobject event); + +/*struct runtime_ { + JavaVM *jvm; + JNIEnv *env; +} ;*/ + +//typedef struct runtime_ *runtime; + +jint start(char* classpath); +void end(); + + +void freeClass(jclass global); +void freeObject(jobject global); + +jclass findClass(const char *name); +jmethodID findMethod(const jclass cls,const char *method,const char *signature); +jmethodID findStaticMethod(const jclass cls,const char *method,const char *signature); +jfieldID findField(const jclass cls,const char *name,const char *signature); +jfieldID findStaticField(const jclass cls,const char *name,const char *signature); + +void registerCallback(const char *clsName,const char *methodName,const char *eventClsName,eventCallback f); +jobject newObject(const jclass cls, const jmethodID method,const jvalue *args,jchar *error); +jstring newString(const jchar *unicode, jsize len,jchar *error); + +jint callIntMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +void callVoidMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jboolean callBooleanMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jchar callCharMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jshort callShortMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jbyte callByteMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jlong callLongMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jdouble callDoubleMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jfloat callFloatMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); +jobject callObjectMethod(const jobject obj,const jmethodID method,const jvalue *args,jchar *error); + +jint callStaticIntMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +void callStaticVoidMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jboolean callStaticBooleanMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jchar callStaticCharMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jshort callStaticShortMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jbyte callStaticByteMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jlong callStaticLongMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jdouble callStaticDoubleMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jfloat callStaticFloatMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); +jobject callStaticObjectMethod(const jclass cls,const jmethodID method,const jvalue *args,jchar *error); + +jint getStaticIntField(const jclass cls,const jfieldID field,jchar *error); +jboolean getStaticBooleanField(const jclass cls,const jfieldID field,jchar *error); +jchar getStaticCharField(const jclass cls,const jfieldID field,jchar *error); +jshort getStaticShortField(const jclass cls,const jfieldID field,jchar *error); +jbyte getStaticByteField(const jclass cls,const jfieldID field,jchar *error); +jlong getStaticLongField(const jclass cls,const jfieldID field,jchar *error); +jdouble getStaticDoubleField(const jclass cls,const jfieldID field,jchar *error); +jfloat getStaticFloatField(const jclass cls,const jfieldID field,jchar *error); +jobject getStaticObjectField(const jclass cls,const jfieldID field,jchar *error); + +void setStaticIntField(const jclass cls,const jfieldID field,jint val,jchar *error); +void setStaticBooleanField(const jclass cls,const jfieldID field,jboolean val,jchar *error); +void setStaticCharField(const jclass cls,const jfieldID field,jchar val,jchar *error); +void setStaticShortField(const jclass cls,const jfieldID field,jshort val,jchar *error); +void setStaticByteField(const jclass cls,const jfieldID field,jbyte val,jchar *error); +void setStaticLongField(const jclass cls,const jfieldID field,jlong val,jchar *error); +void setStaticDoubleField(const jclass cls,const jfieldID field,jdouble val,jchar *error); +void setStaticFloatField(const jclass cls,const jfieldID field,jfloat val,jchar *error); +void setStaticObjectField(const jclass cls,const jfieldID field,jobject val,jchar *error); + +jint getIntField(const jobject obj,const jfieldID field,jchar *error); +jboolean getBooleanField(const jobject obj,const jfieldID field,jchar *error); +jchar getCharField(const jobject obj,const jfieldID field,jchar *error); +jshort getShortField(const jobject obj,const jfieldID field,jchar *error); +jbyte getByteField(const jobject obj,const jfieldID field,jchar *error); +jlong getLongField(const jobject obj,const jfieldID field,jchar *error); +jdouble getDoubleField(const jobject obj,const jfieldID field,jchar *error); +jfloat getFloatField(const jobject obj,const jfieldID field,jchar *error); +jobject getObjectField(const jobject obj,const jfieldID field,jchar *error); + +void setIntField(const jobject obj,const jfieldID field,jint val,jchar *error); +void setBooleanField(const jobject obj,const jfieldID field,jboolean val,jchar *error); +void setCharField(const jobject obj,const jfieldID field,jchar val,jchar *error); +void setShortField(const jobject obj,const jfieldID field,jshort val,jchar *error); +void setByteField(const jobject obj,const jfieldID field,jbyte val,jchar *error); +void setLongField(const jobject obj,const jfieldID field,jlong val,jchar *error); +void setDoubleField(const jobject obj,const jfieldID field,jdouble val,jchar *error); +void setFloatField(const jobject obj,const jfieldID field,jfloat val,jchar *error); +void setObjectField(const jobject obj,const jfieldID field,jobject val,jchar *error); + +#endif diff --git a/src/libjvm.dll.a b/src/libjvm.dll.a new file mode 100644 Binary files /dev/null and b/src/libjvm.dll.a differ diff --git a/test/Language/Java/JVM/APITest.hs b/test/Language/Java/JVM/APITest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Java/JVM/APITest.hs @@ -0,0 +1,226 @@ + +module Language.Java.JVM.APITest where + + +import Language.Java.JVM.API +import Language.Java.JVM.Types + +import Control.Monad.IO.Class +import Foreign.Ptr + +import System.IO.Error +import Test.HUnit + +apiTests::[Test] +apiTests=[testStart,testClassNotFound,testMethodNotFound,testNewString,testIntMethod,testCharMethod,testByteMethod + ,testShortMethod,testLongMethod,testDoubleMethod,testFloatMethod,testBooleanMethod,testObjectMethod,testException + ,testStaticIntMethod,testStaticObjectMethod,testStaticIntField,testIntField,testInterfaceMethod + ,testEnd] + +testStart :: Test +testStart=TestLabel "testStartEnd" (TestCase (do + withJava' False "" (do + liftIO $ assertBool "true" True + return () + ) + )) + +testEnd :: Test +testEnd=TestLabel "testEnd" (TestCase (do + withJava' True "" (do + liftIO $ assertBool "true" True + return () + ) + )) + +testClassNotFound :: Test +testClassNotFound =TestLabel "testClassNotFound" (TestCase (do + ejo<-try $ withJava' False "" (newObject "java/lang/Integer2" "(I)V" [JInt 25]) + case ejo of + Left _ ->return() + Right _->assertFailure "should be able to create Integer2" + el<-try $ withJava' False "" (do + withObject (newObject "java/lang/Integer" "(I)V" [JInt 25]) (\jo-> + byteMethod jo (Method "java/lang/Integer2" "byteValue" "()B") []) + ) + case el of + Left _ ->return() + Right _->assertFailure "should be able to call byteValue on Integer2" + )) + +testMethodNotFound :: Test +testMethodNotFound =TestLabel "testMethodNotFound" (TestCase (do + el<-try $ withJava' False "" (do + jo<-newObject "java/lang/Integer" "(I)V" [JInt 25] + byteMethod jo (Method "java/lang/Integer" "byteValue2" "()B") [] + ) + case el of + Left _ ->return() + Right _->assertFailure "should not be able to call byteValue2 on Integer" + )) + + +testNewString :: Test +testNewString=TestLabel "testNewString" (TestCase (do + withJava' False "" (do + withObject (toJString "hello") (\jo-> + liftIO $ assertBool "jo" (nullPtr/=jo)) + return ()) + )) + +testIntMethod :: Test +testIntMethod=TestLabel "testIntMethod" (TestCase (do + withJava' False "" (do + jo<-toJString "hello" + l<-intMethod jo (Method "java/lang/String" "length" "()I") [] + liftIO $ f_freeObject jo + liftIO $ assertEqual "jo" 5 l + return ()) + )) + +testCharMethod :: Test +testCharMethod=TestLabel "testCharMethod" (TestCase (do + withJava' False "" (do + jo<-toJString "hello" + l<-charMethod jo (Method "java/lang/String" "charAt" "(I)C") [JInt 0] + liftIO $ assertEqual "h" 'h' l + return ()) + )) + +testByteMethod :: Test +testByteMethod=TestLabel "testByteMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Integer" "(I)V" [JInt 25] + l<-byteMethod jo (Method "java/lang/Integer" "byteValue" "()B") [] + liftIO $ assertEqual "25" 25 l + return ()) + )) + +testShortMethod :: Test +testShortMethod=TestLabel "testShortMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Integer" "(I)V" [JInt 25] + l<-shortMethod jo (Method "java/lang/Integer" "shortValue" "()S") [] + liftIO $ assertEqual "25" 25 l + return ()) + )) + +testLongMethod :: Test +testLongMethod=TestLabel "testLongMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Integer" "(I)V" [JInt 25] + l<-longMethod jo (Method "java/lang/Integer" "longValue" "()J") [] + liftIO $ assertEqual "25" 25 l + return ()) + )) + +testDoubleMethod :: Test +testDoubleMethod=TestLabel "testDoubleMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Double" "(D)V" [JDouble 25.67] + l<-doubleMethod jo (Method "java/lang/Double" "doubleValue" "()D") [] + liftIO $ assertEqual "25.67" 25.67 l + return ()) + )) + +testFloatMethod :: Test +testFloatMethod=TestLabel "testFloatMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Float" "(F)V" [JFloat 25.67] + l<-floatMethod jo (Method "java/lang/Float" "floatValue" "()F") [] + liftIO $ assertEqual "25.67" 25.67 l + return ()) + )) + +testBooleanMethod :: Test +testBooleanMethod=TestLabel "testBooleanMethod" (TestCase (do + withJava' False "" (do + jo<-toJString "hello" + l<-booleanMethod jo (Method "java/lang/String" "equals" "(Ljava/lang/Object;)Z") [JObj jo] + liftIO $ f_freeObject jo + liftIO $ assertBool "equals" l + return ()) + )) + +testObjectMethod :: Test +testObjectMethod=TestLabel "testObjectMethod" (TestCase (do + withJava' False "" (do + jo<-newObject "java/lang/Integer" "(I)V" [JInt 25] + s<-objectMethod jo (Method "java/lang/Object" "toString" "()Ljava/lang/String;") [] + liftIO $ f_freeObject jo + freeClass "java/lang/Integer" + liftIO $ assertBool "toString" (nullPtr/=s) + liftIO $ f_freeObject s + return ()) + )) + + +testStaticIntMethod :: Test +testStaticIntMethod=TestLabel "testStaticIntMethod" (TestCase (do + withJava' False "" (do + jo<-toJString "5" + jc<-findClass "java/lang/Integer" + l<-staticIntMethod jc (Method "java/lang/Integer" "parseInt" "(Ljava/lang/String;)I") [JObj jo] + liftIO $ f_freeClass jc + liftIO $ f_freeObject jo + liftIO $ assertEqual "parseInt" 5 l + return ()) + )) + +testStaticObjectMethod :: Test +testStaticObjectMethod=TestLabel "testStaticObjectMethod" (TestCase (do + withJava' False "" (do + jc<-findClass "java/lang/Integer" + jo<-staticObjectMethod jc (Method "java/lang/Integer" "valueOf" "(I)Ljava/lang/Integer;") [JInt 5] + liftIO $ assertBool "testStaticObjectMethod" (nullPtr/=jo) + liftIO $ f_freeClass jc + liftIO $ f_freeObject jo + return ()) + )) + +testStaticIntField :: Test +testStaticIntField=TestLabel "testStaticIntField" (TestCase (do + withJava' False "" (do + jc<-findClass "java/lang/Integer" + l<-getStaticIntField jc (Field "java/lang/Integer" "MAX_VALUE" "I") + liftIO $ assertBool "testStaticIntField" (l>0) + liftIO $ f_freeClass jc + return ()) + )) + +testException :: Test +testException=TestLabel "testException" (TestCase (do + el<-try $ withJava' False "" (do + s<-toJString "aa" + newObject "java/lang/Integer" "(Ljava/lang/String;)V" [JObj s] + ) + case el of + Left _ ->return() + Right _->assertFailure "should be not able to call new Integer with aa" + )) + +testIntField :: Test +testIntField=TestLabel "testIntField" (TestCase (do + withJava' False "" (do + pt<-newObject "java/awt/Point" "()V" [] + let fx=Field "java/awt/Point" "x" "I" + x1<-getIntField pt fx + liftIO $ assertEqual "x1 is not 0" 0 x1 + setIntField pt fx 100 + x2<-getIntField pt fx + liftIO $ assertEqual "x2 is not 100" 100 x2 + return ()) + )) + +testInterfaceMethod :: Test +testInterfaceMethod=TestLabel "testInterfaceMethod" (TestCase (do + withJava' False "" (do + jc<-findClass "java/text/NumberFormat" + jo<-staticObjectMethod jc (Method "java/text/NumberFormat" "getInstance" "()Ljava/text/NumberFormat;") [] + s<-objectMethod jo (Method "java/text/NumberFormat" "format" "(D)Ljava/lang/String;") [JDouble 5.3] + liftIO $ assertBool "format" (nullPtr/=s) + liftIO $ f_freeObject s + liftIO $ f_freeObject jo + liftIO $ f_freeClass jc + ) + )) diff --git a/test/Language/Java/JVM/GeneratorTest.hs b/test/Language/Java/JVM/GeneratorTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Java/JVM/GeneratorTest.hs @@ -0,0 +1,19 @@ + +module Language.Java.JVM.GeneratorTest where + +import Language.Java.JVM.Generator +import Language.Java.JVM.JavapParserTest (parse) +import Language.Haskell.Exts.Pretty + +import Test.HUnit + +generatorTests :: [Test] +generatorTests = [testObject] + +testObject :: Test +testObject=TestLabel "testObject" (TestCase (do + Just td<-parse "java/lang/Object" + let (mod,fp)=generate td + putStrLn $ prettyPrint mod + -- writeFile ("../HJVMBindings/src/Language/Java/JVM/Bindings/"++fp) (prettyPrint mod) + )) diff --git a/test/Language/Java/JVM/JavapParserTest.hs b/test/Language/Java/JVM/JavapParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Java/JVM/JavapParserTest.hs @@ -0,0 +1,45 @@ + +module Language.Java.JVM.JavapParserTest where + +import Language.Java.JVM.JavapParser +import Language.Java.JVM.Generator + +import System.Environment + +import Test.HUnit + +javapParserTests::[Test] +javapParserTests=[testObject,testString] + +parse :: String -> IO (Maybe TypeDecl) +parse cls=do + javaHome<-getEnv "JAVA_HOME" + ep<-parseClass javaHome cls + case ep of + Left err->do + assertFailure $ show err + return Nothing + Right td->return $ Just td + +testObject :: Test +testObject=TestLabel "testObject" (TestCase (do + Just td<-parse "java/lang/Object" + assertEqual "Object has supers!" 0 (length $ td_supers td) + assertBool "Object has no decls!" (0<(length $ td_decls td)) + let toString=JMethodDecl "toString" "()Ljava/lang/String;" False -- simple method + assertBool "Doesn't contain toString" (elem toString $ td_decls td) + let cons=JMethodDecl "" "()V" False + assertBool "Doesn't contain constructor" (elem cons $ td_decls td) -- constructor + let wait=JMethodDecl "wait" "(J)V" False + assertBool "Doesn't contain wait" (elem wait $ td_decls td) -- throws + )) + +testString :: Test +testString=TestLabel "testString" (TestCase (do + Just td<-parse "java/lang/String" + assertEqual "String supers" ["java/lang/Object","java/io/Serializable","java/lang/Comparable","java/lang/CharSequence"] (td_supers td) + let comp=JFieldDecl "CASE_INSENSITIVE_ORDER" "Ljava/util/Comparator;" True -- static field + assertBool "Doesn't contain CASE_INSENSITIVE_ORDER" (elem comp $ td_decls td) + let cons=JMethodDecl "" "([C)V" False + assertBool "Doesn't contain constructor" (elem cons $ td_decls td) -- constructor with array parameter + )) diff --git a/test/Language/Java/JVM/SignatureParserTest.hs b/test/Language/Java/JVM/SignatureParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Java/JVM/SignatureParserTest.hs @@ -0,0 +1,26 @@ + +module Language.Java.JVM.SignatureParserTest where + +import Language.Java.JVM.SignatureParser + +import Test.HUnit + +parse :: String -> IO (Maybe JSignature) +parse sig=do + let ep=parseSignature sig + case ep of + Left err->do + assertFailure $ show err + return Nothing + Right td->return $ Just td + +signatureParserTests :: Test +signatureParserTests = TestLabel "signatureParserTests" (TestCase (do + Just j0<-parse "()V" + assertEqual "noargs, no ret" (JSignature [] Nothing) j0 + Just j1<-parse "(Ljava/lang/Object;)I" + assertEqual "noargs, no ret" (JSignature ["JObj"] (Just "JInt")) j1 + Just j2<-parse "([CII)Ljava/lang/String;" + assertEqual "noargs, no ret" (JSignature ["JObj","JInt","JInt"] (Just "JObj")) j2 + )) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,34 @@ + +module Main where + +import Language.Java.JVM.APITest +import Language.Java.JVM.GeneratorTest +import Language.Java.JVM.JavapParserTest +import Language.Java.JVM.SignatureParserTest + +--import Control.Monad +--import System.Exit (exitFailure) + +import Test.Framework (defaultMain, testGroup,Test) +import Test.Framework.Providers.HUnit + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = [testGroup "API Tests" (concatMap (hUnitTestToTests) apiTests), + testGroup "JavaP Parser Tests" (concatMap (hUnitTestToTests) javapParserTests), + testGroup "Signature Parser Tests" (concatMap (hUnitTestToTests) [signatureParserTests]), + testGroup "Generator Tests" (concatMap (hUnitTestToTests) generatorTests)] + +--main :: IO() +--main = do +-- runHUnitTest apiTests +-- runHUnitTest javapParserTests +-- runHUnitTest signatureParserTests +-- runHUnitTest generatorTests +-- +--runHUnitTest :: Test -> IO () +--runHUnitTest t= do +-- counts1<-runTestTT t +-- when ((errors counts1)>0 || (failures counts1)>0) exitFailure