{-- JVM-Bridge -- bridge from FP languages and others to the Java VM Copyright (C) 2001 Ashley Yakeley <ashley@semantic.org> This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} module Foreign.JavaVM.Typed.Callback where { import Foreign.JavaVM.Typed.Method; import Foreign.JavaVM.Typed.Class; import Foreign.JavaVM.Typed.Tuple(); import Foreign.JavaVM.Typed.Primitive(); import Foreign.JavaVM.Typed.Returnable; import Foreign.JavaVM.Typed.Reference; import Foreign.JavaVM.Typed.Value; import Foreign.JavaVM.Typed.ArgumentList; import Foreign.JavaVM.VM; import Platform.JavaVM; import Control.Monad.Loop; import Control.Concurrent; import Control.Exception; import Data.Witness; startExecuteFunction :: VM (); startExecuteFunction = vmStartExecuteFunction; tlDefineCallbackClass :: VMRef -> ClassName -> ClassName -> [ClassName] -> [ValueType] -> [MethodNameType] -> VM JClass; tlDefineCallbackClass loader classname superclassname interfaces superclassconstructor methods = do { startExecuteFunction; vmDefineCallbackClass loader classname superclassname interfaces superclassconstructor methods; findClassByName classname; -- this is curiously necessary }; reportArgError :: Maybe (VM t) -> VM t; reportArgError (Just vmt) = vmt; reportArgError _ = fail "callback: args: bad list"; makeCallback :: (IsJVMReference c,IsJVMArgumentList a,IsJVMReturnable r) => (c -> a -> VM r) -> VM OpaqueAddress; makeCallback = makeCallback' Type where { makeCallback' :: (IsJVMReference c,IsJVMArgumentList a,IsJVMReturnable r) => Type a -> (c -> a -> VM r) -> VM OpaqueAddress; makeCallback' t foo = tlMakeCallback (AnyWitness Tref:getArgTypes t) (\vobjargs -> do { case vobjargs of { (vobj:vargs) -> do { obj <- reportArgError (tlExtractValue vobj); args <- reportArgError (tlExtractValues vargs); foo obj args; }; _ -> fail "callback: args: no object"; }; }); }; makeStaticCallback :: (IsJVMArgumentList a,IsJVMReturnable r) => (a -> VM r) -> VM OpaqueAddress; makeStaticCallback = makeStaticCallback' Type where { makeStaticCallback' :: (IsJVMArgumentList a,IsJVMReturnable r) => Type a -> (a -> VM r) -> VM OpaqueAddress; makeStaticCallback' t foo = tlMakeCallback (getArgTypes t) (\vargs -> do { args <- reportArgError (tlExtractValues vargs); foo args; }); }; getExecuteFunctionClass :: VM JClass; getExecuteFunctionClass = do { startExecuteFunction; findClassByName executeFunctionClassName; }; getprocPending :: JClass -> VM (() -> IO Jboolean); getprocPending execClass = getStaticMethod execClass "procPending"; getdoNextProc :: JClass -> VM (() -> IO ()); getdoNextProc execClass = getStaticMethod execClass "doNextProc"; runProcs :: VM Jboolean -> VM () -> VM Bool -> VM (); runProcs procPending doNextProc stopNow = do { stop <- stopNow; if (stop) then (return ()) else (do { pending <- procPending; if (pending) then (do { forkIO (do { result <- doNextProc; return result; }); return (); }) else (return ()); Control.Concurrent.yield; runProcs procPending doNextProc stopNow; }); }; -- returns the 'stop' proc. startProcsThread :: VM (IO ()); startProcsThread = do { executeClass <- getExecuteFunctionClass; procPending <- getprocPending executeClass; doNextProc <- getdoNextProc executeClass; stopVar <- newEmptyMVar; forkIO (runProcs (procPending ()) (doNextProc ()) (isEmptyMVar stopVar >>= (return . not))); return (tryPutMVar stopVar () >> return ()); }; withProcsThread :: VM a -> VM a; withProcsThread f = bracket startProcsThread id (const f); tlYieldLoop :: (() -> VM ()) -> VM Bool -> VM (); tlYieldLoop yieldMethod stopNow = do { while (do { stop <- stopNow; if (stop) then (return True) else (do { yieldMethod (); Control.Concurrent.yield; return False; }); }); }; }