{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      : StatusNotifier.TransparentWindow
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- Make a window transparent. Approach adapted from python code from
-- https://stackoverflow.com/questions/3908565/how-to-make-gtk-window-background-transparent/33294727#33294727
-----------------------------------------------------------------------------
module StatusNotifier.TransparentWindow where

import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import           Data.GI.Base
import           Foreign.Ptr (castPtr)
import           GI.Cairo hiding (OperatorOver, OperatorSource)
import           GI.Cairo.Render
import           GI.Cairo.Render.Connector
import qualified GI.Gdk as Gdk
import qualified GI.Gtk as Gtk

makeWindowTransparent :: MonadIO m => Gtk.Window -> m ()
makeWindowTransparent :: forall (m :: * -> *). MonadIO m => Window -> m ()
makeWindowTransparent Window
window = do
  Screen
screen <- Window -> m Screen
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Screen
Gtk.widgetGetScreen Window
window
  Maybe Visual
visual <- Screen -> m (Maybe Visual)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsScreen a) =>
a -> m (Maybe Visual)
Gdk.screenGetRgbaVisual Screen
screen
  Window -> Maybe Visual -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWidget a, IsVisual b) =>
a -> Maybe b -> m ()
Gtk.widgetSetVisual Window
window Maybe Visual
visual
  Window -> Bool -> m ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Bool -> m ()
Gtk.setWidgetAppPaintable Window
window Bool
True
  SignalHandlerId
_ <- Window
-> ((?self::Window) => WidgetDrawCallback) -> m SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => WidgetDrawCallback) -> m SignalHandlerId
Gtk.onWidgetDraw Window
window (?self::Window) => WidgetDrawCallback
WidgetDrawCallback
transparentDraw
  () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

transparentDraw :: Gtk.WidgetDrawCallback
transparentDraw :: WidgetDrawCallback
transparentDraw Context
context = do
  RGBA
rGBA <- IO RGBA
forall (m :: * -> *). MonadIO m => m RGBA
Gdk.newZeroRGBA
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
Gdk.setRGBAAlpha RGBA
rGBA Double
0.0
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
Gdk.setRGBABlue RGBA
rGBA Double
1.0
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
Gdk.setRGBARed RGBA
rGBA Double
1.0
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
Gdk.setRGBAGreen RGBA
rGBA Double
1.0
  Context -> RGBA -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Context -> RGBA -> m ()
Gdk.cairoSetSourceRgba Context
context RGBA
rGBA
  (Render () -> Context -> IO ()) -> Context -> Render () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Render () -> Context -> IO ()
forall (m :: * -> *) a. MonadIO m => Render a -> Context -> m a
renderWithContext Context
context (Render () -> IO ()) -> Render () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Operator -> Render ()
setOperator Operator
OperatorSource
    Render ()
paint
    Operator -> Render ()
setOperator Operator
OperatorOver
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False