{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.FadeWindows
-- Description :  A more flexible and general compositing interface than FadeInactive.
-- Copyright   :  Brandon S Allbery KF8NH <allbery.b@gmail.com>
-- License     :  BSD
--
-- Maintainer  :  Brandon S Allbery KF8NH
-- Stability   :  unstable
-- Portability :  unportable
--
-- A more flexible and general compositing interface than FadeInactive.
-- Windows can be selected and opacity specified by means of FadeHooks,
-- which are very similar to ManageHooks and use the same machinery.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.FadeWindows (-- * Usage
                                 -- $usage

                                 -- * The 'logHook' for window fading
                                 fadeWindowsLogHook

                                 -- * The 'FadeHook'
                                ,FadeHook
                                ,Opacity
                                ,idFadeHook

                                 -- * Predefined 'FadeHook's
                                ,opaque
                                ,solid
                                ,transparent
                                ,invisible
                                ,transparency
                                ,translucence
                                ,fadeBy
                                ,opacity
                                ,fadeTo

                                -- * 'handleEventHook' for mapped/unmapped windows
                                ,fadeWindowsEventHook

                                -- * 'doF' for simple hooks
                                ,doS

                                -- * Useful 'Query's for 'FadeHook's
                                ,isFloating
                                ,isUnfocused
                                ) where

import           XMonad.Core
import           XMonad.Prelude
import           XMonad.ManageHook                       (liftX)
import qualified XMonad.StackSet             as W

import           XMonad.Hooks.FadeInactive               (setOpacity
                                                         ,isUnfocused
                                                         )

import           Control.Monad.Reader                    (ask
                                                         ,asks)
import           Control.Monad.State                     (gets)
import qualified Data.Map                    as M

import           Graphics.X11.Xlib.Extras                (Event(..))

-- $usage
-- To use this module, make sure your @xmonad@ core supports generalized
-- 'ManageHook's (check the type of 'idHook'; if it's @ManageHook@ then
-- your @xmonad@ is too old) and then add @fadeWindowsLogHook@ to your
-- 'logHook' and @fadeWindowsEventHook@ to your 'handleEventHook':
--
-- >     , logHook = fadeWindowsLogHook myFadeHook
-- >     , handleEventHook = fadeWindowsEventHook
-- >     {- ... -}
-- >
-- > myFadeHook = composeAll [                 opaque
-- >                         , isUnfocused --> transparency 0.2
-- >                         ]
--
-- The above is like FadeInactive with a fade value of 0.2.
--
-- 'FadeHook's do not accumulate; instead, they compose from right to
-- left like 'ManageHook's, so in the above example @myFadeHook@ will
-- render unfocused windows at 4/5 opacity and the focused window as
-- opaque.  This means that, in particular, the order in the above
-- example is important.
--
-- The 'opaque' hook above is optional, by the way, as any unmatched
-- window will be opaque by default.  If you want to make all windows a
-- bit transparent by default, you can replace 'opaque' with something
-- like
--
-- > transparency 0.93
--
-- at the top of @myFadeHook@.
--
-- This module is best used with "XMonad.Hooks.MoreManageHelpers", which
-- exports a number of Queries that can be used in either @ManageHook@
-- or @FadeHook@.
--
-- Note that you need a compositing manager such as @xcompmgr@,
-- @dcompmgr@, or @cairo-compmgr@ for window fading to work.  If you
-- aren't running a compositing manager, the opacity will be recorded
-- but won't take effect until a compositing manager is started.
--
-- For more detailed instructions on editing the 'logHook' see:
--
-- "XMonad.Doc.Extending#The_log_hook_and_external_status_bars"
--
-- For more detailed instructions on editing the 'handleEventHook',
-- see:
--
-- "XMonad.Doc.Extending#Editing_the_event_hook"
-- (which sadly doesnt exist at the time of writing...)
--
-- /WARNING:/  This module is very good at triggering bugs in
-- compositing managers.  Symptoms range from windows not being
-- repainted until the compositing manager is restarted or the
-- window is unmapped and remapped, to the machine becoming sluggish
-- until the compositing manager is restarted (at which point a
-- popup/dialog will suddenly appear; apparently it's getting into
-- a tight loop trying to fade the popup in).  I find it useful to
-- have a key binding to restart the compositing manager; for example,
--
-- main = xmonad $ def {
--                   {- ... -}
--                 }
--                 `additionalKeysP`
--                 [("M-S-4",spawn "killall xcompmgr; sleep 1; xcompmgr -cCfF &")]
--                 {- ... -}
--                 ]
--
-- (See "XMonad.Util.EZConfig" for 'additionalKeysP'.)

-- a window opacity to be carried in a Query.  OEmpty is sort of a hack
-- to make it obay the monoid laws
data Opacity = Opacity Rational | OEmpty

instance Semigroup Opacity where
  Opacity
r <> :: Opacity -> Opacity -> Opacity
<> Opacity
OEmpty = Opacity
r
  Opacity
_ <> Opacity
r      = Opacity
r

instance Monoid Opacity where
  mempty :: Opacity
mempty                  = Opacity
OEmpty

-- | A FadeHook is similar to a ManageHook, but records window opacity.
type FadeHook = Query Opacity

-- | Render a window fully opaque.
opaque :: FadeHook
opaque :: FadeHook
opaque =  Opacity -> FadeHook
forall m. Monoid m => m -> Query m
doS (Rational -> Opacity
Opacity Rational
1)

-- | Render a window fully transparent.
transparent :: FadeHook
transparent :: FadeHook
transparent =  Opacity -> FadeHook
forall m. Monoid m => m -> Query m
doS (Rational -> Opacity
Opacity Rational
0)

-- | Specify a window's transparency.
transparency :: Rational -- ^ The window's transparency as a fraction.
                         --   @transparency 1@ is the same as 'transparent',
                         --   whereas @transparency 0@ is the same as 'opaque'.
             -> FadeHook
transparency :: Rational -> FadeHook
transparency =  Opacity -> FadeHook
forall m. Monoid m => m -> Query m
doS (Opacity -> FadeHook)
-> (Rational -> Opacity) -> Rational -> FadeHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Opacity
Opacity (Rational -> Opacity)
-> (Rational -> Rational) -> Rational -> Opacity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational
1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
-) (Rational -> Rational)
-> (Rational -> Rational) -> Rational -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
clampRatio

-- | Specify a window's opacity; this is the inverse of 'transparency'.
opacity :: Rational -- ^ The opacity of a window as a fraction.
                    --   @opacity 1@ is the same as 'opaque',
                    --   whereas @opacity 0@ is the same as 'transparent'.
        -> FadeHook
opacity :: Rational -> FadeHook
opacity =  Opacity -> FadeHook
forall m. Monoid m => m -> Query m
doS (Opacity -> FadeHook)
-> (Rational -> Opacity) -> Rational -> FadeHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Opacity
Opacity (Rational -> Opacity)
-> (Rational -> Rational) -> Rational -> Opacity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
clampRatio

fadeTo, translucence, fadeBy :: Rational -> FadeHook
-- | An alias for 'transparency'.
fadeTo :: Rational -> FadeHook
fadeTo       = Rational -> FadeHook
transparency
-- | An alias for 'transparency'.
translucence :: Rational -> FadeHook
translucence = Rational -> FadeHook
transparency
-- | An alias for 'opacity'.
fadeBy :: Rational -> FadeHook
fadeBy       = Rational -> FadeHook
opacity

invisible, solid :: FadeHook
-- | An alias for 'transparent'.
invisible :: FadeHook
invisible    = FadeHook
transparent
-- | An alias for 'opaque'.
solid :: FadeHook
solid        = FadeHook
opaque

-- | Like 'doF', but usable with 'ManageHook'-like hooks that
-- aren't 'Query' wrapped around transforming functions ('Endo').
doS :: Monoid m => m -> Query m
doS :: forall m. Monoid m => m -> Query m
doS =  m -> Query m
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | The identity 'FadeHook', which renders windows 'opaque'.
idFadeHook :: FadeHook
idFadeHook :: FadeHook
idFadeHook =  FadeHook
opaque

-- | A Query to determine if a window is floating.
isFloating :: Query Bool
isFloating :: Query Bool
isFloating =  Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query Bool) -> Query Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X Bool -> Query Bool
forall a. X a -> Query a
liftX (X Bool -> Query Bool)
-> ((XState -> Bool) -> X Bool) -> (XState -> Bool) -> Query Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XState -> Bool) -> X Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Bool) -> Query Bool) -> (XState -> Bool) -> Query Bool
forall a b. (a -> b) -> a -> b
$ Window -> Map Window RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Window
w (Map Window RationalRect -> Bool)
-> (XState -> Map Window RationalRect) -> XState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> Map Window RationalRect)
-> (XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Map Window RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset

-- boring windows can't be seen outside of a layout, so we watch messages with
-- a dummy LayoutModifier and stow them in a persistent bucket.  this is not
-- entirely reliable given that boringAuto still isn't observable; we just hope
-- those aren't visible and won;t be affected anyway
-- @@@ punted for now, will be a separate module.  it's still slimy, though

-- | A 'logHook' to fade windows under control of a 'FadeHook', which is
--   similar to but not identical to 'ManageHook'.
fadeWindowsLogHook   :: FadeHook -> X ()
fadeWindowsLogHook :: FadeHook -> X ()
fadeWindowsLogHook FadeHook
h =  (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> X ())
-> X ()
forall a.
(StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> X a)
-> X a
withWindowSet ((StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
  -> X ())
 -> X ())
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> X ())
-> X ()
forall a b. (a -> b) -> a -> b
$ \StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
s -> do
  let visibleWins :: [Window]
visibleWins = (Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Window) -> [Window])
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Maybe (Stack Window))
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace WorkspaceId (Layout Window) Window
-> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace WorkspaceId (Layout Window) Window
 -> Maybe (Stack Window))
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Window) Window)
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> Workspace WorkspaceId (Layout Window) Window)
-> (StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> [Window])
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Window]
forall a b. (a -> b) -> a -> b
$ StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
s) [Window] -> [Window] -> [Window]
forall a. [a] -> [a] -> [a]
++
                    (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> [Window])
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Window]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Window) -> [Window])
-> (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Maybe (Stack Window))
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace WorkspaceId (Layout Window) Window
-> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace WorkspaceId (Layout Window) Window
 -> Maybe (Stack Window))
-> (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Window) Window)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Workspace WorkspaceId (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
s)
  [Window] -> (Window -> X ()) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Window]
visibleWins ((Window -> X ()) -> X ()) -> (Window -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    Opacity
o <- Opacity -> X Opacity -> X Opacity
forall a. a -> X a -> X a
userCodeDef (Rational -> Opacity
Opacity Rational
1) (FadeHook -> Window -> X Opacity
forall a. Query a -> Window -> X a
runQuery FadeHook
h Window
w)
    Window -> Rational -> X ()
setOpacity Window
w (Rational -> X ()) -> Rational -> X ()
forall a b. (a -> b) -> a -> b
$ case Opacity
o of
                     Opacity
OEmpty    -> Rational
1
                     Opacity Rational
r -> Rational
r

-- | A 'handleEventHook' to handle fading and unfading of newly mapped
--   or unmapped windows; this avoids problems with layouts such as
--   "XMonad.Layout.Full" or "XMonad.Layout.Tabbed".  This hook may
--   also be useful with "XMonad.Hooks.FadeInactive".
fadeWindowsEventHook                     :: Event -> X All
fadeWindowsEventHook :: Event -> X All
fadeWindowsEventHook MapNotifyEvent{} =
  -- we need to run the fadeWindowsLogHook.  only one way...
  (XConf -> XConfig Layout) -> X (XConfig Layout)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> XConfig Layout
config X (XConfig Layout) -> (XConfig Layout -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook X () -> X All -> X All
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
fadeWindowsEventHook Event
_                   =  All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- A utility to clamp opacity fractions to the range (0,1)
clampRatio   :: Rational         -> Rational
clampRatio :: Rational -> Rational
clampRatio Rational
r |  Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0 Bool -> Bool -> Bool
&& Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
1 =  Rational
r
             |  Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0            =  Rational
0
             |  Bool
otherwise        =  Rational
1