{-# LANGUAGE ScopedTypeVariables #-}

-- This is needed because of using the IsWidget constraint synonym in
-- printWidgetTree.  See
-- https://github.com/haskell-gi/haskell-gi/pull/376#discussion_r786423429
-- for a little discussion of this.
{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-}

-- |
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Helper functions for working with 'Widget's.

module Data.GI.Gtk.Widget
    ( printWidgetTree
    ) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Foldable (for_)
import Data.GI.Base.GObject (gtypeFromInstance)
import GI.Gtk.Objects.Widget (IsWidget, Widget, toWidget)
import GI.Gtk (Container(Container), castTo, containerGetChildren, gtypeName, managedForeignPtr, toManagedPtr)

-- | Print out a tree of decendents for a given GTK 'Widget'.  This function is
-- mainly to help with debugging.
--
-- This function outputs a tree of 'Widget's like the following:
--
-- > GtkApplicationWindow  0x00000000068de2a0
-- >   GtkMenuBar  0x0000000006c661d0
-- >     GtkModelMenuItem  0x0000000006c72b00
-- >       GtkAccelLabel  0x0000000006c73b60
-- >     GtkModelMenuItem  0x0000000006c723c0
-- >       GtkAccelLabel  0x0000000006c733a0
-- >   GtkNotebook  0x0000000006b0a200
-- >     GtkPaned  0x0000000006b073c0
-- >       GtkScrolledWindow  0x0000000006b0c7c0
-- >         VteTerminal  0x00000000068af4a0
-- >       GtkScrolledWindow  0x0000000006b0c470
-- >         VteTerminal  0x00000000068af370
--
-- Note that you may also be interested in
-- <https://wiki.gnome.org/Projects/GTK/Inspector GTKInspector>, which is a
-- built-in interactive debugger for GTK applications.
printWidgetTree :: forall m a. (MonadIO m, IsWidget a) => a -> m ()
printWidgetTree :: forall (m :: * -> *) a. (MonadIO m, IsWidget a) => a -> m ()
printWidgetTree a
widget_ = do
  Widget
widget <- a -> m Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget a
widget_
  String -> Widget -> m ()
go String
"" Widget
widget
  where
    go :: String -> Widget -> m ()
    go :: String -> Widget -> m ()
go String
indent Widget
w = do
      GType
type_ <- IO GType -> m GType
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GType -> m GType) -> IO GType -> m GType
forall a b. (a -> b) -> a -> b
$ Widget -> IO GType
forall o. GObject o => o -> IO GType
gtypeFromInstance Widget
w
      String
name <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ GType -> IO String
gtypeName GType
type_
      let ptr :: ForeignPtr Widget
ptr = ManagedPtr Widget -> ForeignPtr Widget
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr (ManagedPtr Widget -> ForeignPtr Widget)
-> (Widget -> ManagedPtr Widget) -> Widget -> ForeignPtr Widget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget -> ManagedPtr Widget
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr (Widget -> ForeignPtr Widget) -> Widget -> ForeignPtr Widget
forall a b. (a -> b) -> a -> b
$ Widget
w
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
indent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ForeignPtr Widget -> String
forall a. Show a => a -> String
show ForeignPtr Widget
ptr
      Maybe Container
maybeContainer <- IO (Maybe Container) -> m (Maybe Container)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Container) -> m (Maybe Container))
-> IO (Maybe Container) -> m (Maybe Container)
forall a b. (a -> b) -> a -> b
$ (ManagedPtr Container -> Container)
-> Widget -> IO (Maybe Container)
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr Container -> Container
Container Widget
w
      Maybe Container -> (Container -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Container
maybeContainer ((Container -> m ()) -> m ()) -> (Container -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Container
container -> do
        [Widget]
children <- Container -> m [Widget]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsContainer a) =>
a -> m [Widget]
containerGetChildren Container
container
        [Widget] -> (Widget -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Widget]
children ((Widget -> m ()) -> m ()) -> (Widget -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Widget
child -> do
          String -> Widget -> m ()
go (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
indent) Widget
child