{-# 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 <- a -> m Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget a
widget_
  go "" widget
  where
    go :: String -> Widget -> m ()
    go :: String -> Widget -> m ()
go String
indent Widget
w = do
      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
      name <- liftIO $ gtypeName type_
      let 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
      liftIO $ putStrLn $ indent <> name <> "  " <> show ptr
      maybeContainer <- liftIO $ castTo Container w
      for_ maybeContainer $ \Container
container -> do
        children <- Container -> m [Widget]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsContainer a) =>
a -> m [Widget]
containerGetChildren Container
container
        for_ children $ \Widget
child -> do
          String -> Widget -> m ()
go (String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
indent) Widget
child