Class.hs

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{-# LANGUAGE TypeApplications, DefaultSignatures, StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Reflex.GI.Gtk.Run.Class
  ( MonadRunGtk( askRunGtk_
               , askRunGtk
               , askRunGtkPromise
               , askMakeSynchronousFire
               )
  , runGtk_
  , runGtk
  , runGtkPromise
  ) where

import Control.Monad (join)
import Control.Monad.IO.Class ( MonadIO
                              , liftIO
                              )
import Control.Monad.Reader (ReaderT(ReaderT))
import Control.Monad.Trans (lift)
import Reflex ( PostBuildT(PostBuildT)
              , TriggerEventT(TriggerEventT)
              )

class (MonadIO m) => MonadRunGtk m where
  askRunGtk :: m (IO a -> IO a)
  askRunGtk = (join .) <$> askRunGtkPromise

  askRunGtk_ :: m (IO a -> IO ())

  askRunGtkPromise :: m (IO a -> IO (IO a))

  askMakeSynchronousFire :: m ((a -> IO () -> IO ()) -> a -> IO ())

deriving instance MonadRunGtk m => MonadRunGtk (PostBuildT t m)
deriving instance MonadRunGtk m => MonadRunGtk (TriggerEventT t m)

instance MonadRunGtk m => MonadRunGtk (ReaderT r m) where
  askRunGtk = lift askRunGtk
  askRunGtk_ = lift askRunGtk_
  askRunGtkPromise = lift askRunGtkPromise
  askMakeSynchronousFire = lift askMakeSynchronousFire

runGtk :: (MonadRunGtk m) => IO a -> m a
runGtk a = askRunGtk >>= liftIO . ($a)

runGtk_ :: (MonadRunGtk m) => IO a -> m ()
runGtk_ a = askRunGtk_ >>= liftIO . ($a)

runGtkPromise :: (MonadRunGtk m) => IO a -> m (m a)
runGtkPromise a = askRunGtkPromise >>= liftIO . fmap liftIO . ($a)