{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-}
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)
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