{-# LANGUAGE CPP #-}

module Termonad.Gtk where

import Termonad.Prelude

import Control.Monad.Fail (MonadFail, fail)
import Data.GI.Base (ManagedPtr, withManagedPtr)
import GHC.Stack (HasCallStack)
import GI.Gdk
  ( GObject
  , castTo
  )
import GI.Gio (ApplicationFlags)
import GI.Gtk (Application, IsWidget, Widget(Widget), applicationNew, builderGetObject, toWidget)
import qualified GI.Gtk as Gtk


objFromBuildUnsafe ::
     GObject o => Gtk.Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe :: Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe builder :: Builder
builder name :: Text
name constructor :: ManagedPtr o -> o
constructor = do
  Maybe Object
maybePlainObj <- Builder -> Text -> IO (Maybe Object)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsBuilder a) =>
a -> Text -> m (Maybe Object)
builderGetObject Builder
builder Text
name
  case Maybe Object
maybePlainObj of
    Nothing -> [Char] -> IO o
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO o) -> [Char] -> IO o
forall a b. (a -> b) -> a -> b
$ "Couldn't get " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> " from builder!"
    Just plainObj :: Object
plainObj -> do
      Maybe o
maybeNewObj <- (ManagedPtr o -> o) -> Object -> IO (Maybe o)
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr o -> o
constructor Object
plainObj
      case Maybe o
maybeNewObj of
        Nothing ->
          [Char] -> IO o
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO o) -> [Char] -> IO o
forall a b. (a -> b) -> a -> b
$
            "Got " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
            Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
            " from builder, but couldn't convert to object!"
        Just obj :: o
obj -> o -> IO o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
obj

-- | Unsafely creates a new 'Application'.  This calls 'fail' if it cannot
-- create the 'Application' for some reason.
--
-- This can fail for different reasons, one of which being that application
-- name does not have a period in it.
appNew ::
     (HasCallStack, MonadIO m, MonadFail m)
  => Maybe Text
  -- ^ The application name.  Must have a period in it if specified.  If passed
  -- as 'Nothing', then no application name will be used.
  -> [ApplicationFlags]
  -> m Application
appNew :: Maybe Text -> [ApplicationFlags] -> m Application
appNew appName :: Maybe Text
appName appFlags :: [ApplicationFlags]
appFlags = do
  Maybe Application
maybeApp <- Maybe Text -> [ApplicationFlags] -> m (Maybe Application)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> [ApplicationFlags] -> m (Maybe Application)
applicationNew Maybe Text
appName [ApplicationFlags]
appFlags
  case Maybe Application
maybeApp of
    Nothing -> [Char] -> m Application
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail "Could not create application for some reason!"
    Just app :: Application
app -> Application -> m Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure Application
app

-- | Tests to see if two GTK widgets point to the same thing.  This should only
-- happen if they are actually the same thing.
widgetEq :: (MonadIO m, IsWidget a, IsWidget b) => a -> b -> m Bool
widgetEq :: a -> b -> m Bool
widgetEq a :: a
a b :: b
b = do
  Widget managedPtrA :: ManagedPtr Widget
managedPtrA <- a -> m Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget a
a
  Widget managedPtrB :: ManagedPtr Widget
managedPtrB <- b -> m Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget b
b
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
    ManagedPtr Widget
-> (Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr ManagedPtr Widget
managedPtrA ((Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool)
-> (Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ptrA :: Ptr (ManagedPtr Widget)
ptrA ->
      ManagedPtr Widget
-> (Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr ManagedPtr Widget
managedPtrB ((Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool)
-> (Ptr (ManagedPtr Widget) -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ptrB :: Ptr (ManagedPtr Widget)
ptrB ->
        Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr (ManagedPtr Widget)
ptrA Ptr (ManagedPtr Widget) -> Ptr (ManagedPtr Widget) -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr (ManagedPtr Widget)
ptrB)