{-# LANGUAGE ForeignFunctionInterface #-} module Android.HaskellActivity ( ActivityCallbacks (..) , HaskellActivity (..) , getHaskellActivity , getFilesDir , getCacheDir , continueWithCallbacks , traceActivityCallbacks ) where import Control.Exception import Control.Monad import Data.Default import Debug.Trace import Foreign.C.String import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable #include "HaskellActivity.h" newtype HaskellActivity = HaskellActivity { unHaskellActivity :: Ptr HaskellActivity } foreign import ccall unsafe "HaskellActivity_get" getHaskellActivity :: IO HaskellActivity foreign import ccall unsafe "HaskellActivity_getFilesDir" getFilesDirCString :: HaskellActivity -> IO CString foreign import ccall unsafe "HaskellActivity_getCacheDir" getCacheDirCString :: HaskellActivity -> IO CString -- | Copy a C string into Haskell returning 'Nothing' if it is NULL. peekMaybeCString :: CString -> IO (Maybe String) peekMaybeCString str = if str == nullPtr then return Nothing else Just <$> peekCString str -- | Get the "internal" storage directory for the app. This is where data local -- to the app should be stored. Note that 'Nothing' is returned if the activity -- is not fully initalized. In practice this means you probably need to call -- this inside the main widget. getFilesDir :: HaskellActivity -> IO (Maybe FilePath) getFilesDir = getFilesDirCString >=> peekMaybeCString -- | Get the cache storage directory for the app. Android may delete this data -- at any time. Note that 'Nothing' is returned if the activity is not fully -- initalized. In practice this means you probably need to call this inside the -- main widget. getCacheDir :: HaskellActivity -> IO (Maybe FilePath) getCacheDir = getCacheDirCString >=> peekMaybeCString -- | Allow the HaskellActivity to proceed. The given callbacks will be invoked -- at the appropriate times in the Android Activity lifecycle. -- WARNING: This should only be invoked once per application execution. continueWithCallbacks :: ActivityCallbacks -> IO () continueWithCallbacks ac = do continueWithCallbacks_ =<< new =<< activityCallbacksToPtrs ac foreign import ccall safe "HaskellActivity_continueWithCallbacks" continueWithCallbacks_ :: Ptr ActivityCallbacksPtrs -> IO () data ActivityCallbacks = ActivityCallbacks { _activityCallbacks_onCreate :: () -> IO () -- The () input here will eventually become a representation of the Bundle that Android passes in; this placeholder is to make the change easier , _activityCallbacks_onStart :: IO () , _activityCallbacks_onResume :: IO () , _activityCallbacks_onPause :: IO () , _activityCallbacks_onStop :: IO () , _activityCallbacks_onDestroy :: IO () , _activityCallbacks_onRestart :: IO () , _activityCallbacks_onBackPressed :: IO () , _activityCallbacks_onNewIntent :: String -> String -> IO () , _activityCallbacks_firebaseInstanceIdServiceSendRegistrationToServer :: String -> IO () } instance Default ActivityCallbacks where def = ActivityCallbacks { _activityCallbacks_onCreate = \_ -> return () , _activityCallbacks_onStart = return () , _activityCallbacks_onResume = return () , _activityCallbacks_onPause = return () , _activityCallbacks_onStop = return () , _activityCallbacks_onDestroy = return () , _activityCallbacks_onRestart = return () , _activityCallbacks_onBackPressed = return () , _activityCallbacks_onNewIntent = \_ _ -> return () , _activityCallbacks_firebaseInstanceIdServiceSendRegistrationToServer = \_ -> return () } traceBracket :: String -> IO a -> IO a traceBracket s = bracket (traceIO $ s <> " entered") (\_ -> traceIO $ s <> " exited") . const traceActivityCallbacks :: ActivityCallbacks -> ActivityCallbacks traceActivityCallbacks ac = ActivityCallbacks { _activityCallbacks_onCreate = \x -> traceBracket "onCreate" $ _activityCallbacks_onCreate ac x , _activityCallbacks_onStart = traceBracket "onStart" $ _activityCallbacks_onStart ac , _activityCallbacks_onResume = traceBracket "onResume" $ _activityCallbacks_onResume ac , _activityCallbacks_onPause = traceBracket "onPause" $ _activityCallbacks_onPause ac , _activityCallbacks_onStop = traceBracket "onStop" $ _activityCallbacks_onStop ac , _activityCallbacks_onDestroy = traceBracket "onDestroy" $ _activityCallbacks_onDestroy ac , _activityCallbacks_onRestart = traceBracket "onRestart" $ _activityCallbacks_onRestart ac , _activityCallbacks_onNewIntent = \x y -> traceBracket "onNewIntent" $ _activityCallbacks_onNewIntent ac x y , _activityCallbacks_onBackPressed = traceBracket "onBackPressed" $ _activityCallbacks_onBackPressed ac , _activityCallbacks_firebaseInstanceIdServiceSendRegistrationToServer = \x -> traceBracket "firebaseInstanceIdServiceSendRegistrationToServer" $ _activityCallbacks_firebaseInstanceIdServiceSendRegistrationToServer ac x } foreign import ccall "wrapper" wrapIO :: IO () -> IO (FunPtr (IO ())) foreign import ccall "wrapper" wrapCStringIO :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) foreign import ccall "wrapper" wrapCStringCStringIO :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) activityCallbacksToPtrs :: ActivityCallbacks -> IO ActivityCallbacksPtrs activityCallbacksToPtrs ac = ActivityCallbacksPtrs <$> wrapIO (_activityCallbacks_onCreate ac ()) <*> wrapIO (_activityCallbacks_onStart ac) <*> wrapIO (_activityCallbacks_onResume ac) <*> wrapIO (_activityCallbacks_onPause ac) <*> wrapIO (_activityCallbacks_onStop ac) <*> wrapIO (_activityCallbacks_onDestroy ac) <*> wrapIO (_activityCallbacks_onRestart ac) <*> wrapIO (_activityCallbacks_onBackPressed ac) <*> wrapCStringCStringIO (\a b -> do a' <- peekCString a b' <- peekCString b _activityCallbacks_onNewIntent ac a' b' ) <*> wrapCStringIO (\token -> do token' <- peekCString token _activityCallbacks_firebaseInstanceIdServiceSendRegistrationToServer ac token' ) data ActivityCallbacksPtrs = ActivityCallbacksPtrs { _activityCallbacksPtrs_onCreate :: FunPtr (IO ()) , _activityCallbacksPtrs_onStart :: FunPtr (IO ()) , _activityCallbacksPtrs_onResume :: FunPtr (IO ()) , _activityCallbacksPtrs_onPause :: FunPtr (IO ()) , _activityCallbacksPtrs_onStop :: FunPtr (IO ()) , _activityCallbacksPtrs_onDestroy :: FunPtr (IO ()) , _activityCallbacksPtrs_onRestart :: FunPtr (IO ()) , _activityCallbacksPtrs_onBackPressed :: FunPtr (IO ()) , _activityCallbacksPtrs_onNewIntent :: FunPtr (CString -> CString -> IO ()) , _activityCallbacksPtrs_firebaseInstanceIdService_sendRegistrationToServer :: FunPtr (CString -> IO ()) } instance Storable ActivityCallbacksPtrs where sizeOf _ = #{size ActivityCallbacks} alignment _ = #{alignment ActivityCallbacks} poke p ac = do #{poke ActivityCallbacks, onCreate} p $ _activityCallbacksPtrs_onCreate ac #{poke ActivityCallbacks, onStart} p $ _activityCallbacksPtrs_onStart ac #{poke ActivityCallbacks, onResume} p $ _activityCallbacksPtrs_onResume ac #{poke ActivityCallbacks, onPause} p $ _activityCallbacksPtrs_onPause ac #{poke ActivityCallbacks, onStop} p $ _activityCallbacksPtrs_onStop ac #{poke ActivityCallbacks, onDestroy} p $ _activityCallbacksPtrs_onDestroy ac #{poke ActivityCallbacks, onRestart} p $ _activityCallbacksPtrs_onRestart ac #{poke ActivityCallbacks, onBackPressed} p $ _activityCallbacksPtrs_onBackPressed ac #{poke ActivityCallbacks, onNewIntent} p $ _activityCallbacksPtrs_onNewIntent ac #{poke ActivityCallbacks, firebaseInstanceIdService_sendRegistrationToServer} p $ _activityCallbacksPtrs_firebaseInstanceIdService_sendRegistrationToServer ac peek p = ActivityCallbacksPtrs <$> #{peek ActivityCallbacks, onCreate} p <*> #{peek ActivityCallbacks, onStart} p <*> #{peek ActivityCallbacks, onResume} p <*> #{peek ActivityCallbacks, onPause} p <*> #{peek ActivityCallbacks, onStop} p <*> #{peek ActivityCallbacks, onDestroy} p <*> #{peek ActivityCallbacks, onRestart} p <*> #{peek ActivityCallbacks, onBackPressed} p <*> #{peek ActivityCallbacks, onNewIntent} p <*> #{peek ActivityCallbacks, firebaseInstanceIdService_sendRegistrationToServer} p