-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.Qubes
-- Description :  Use Qubes OS label colours for window borders.
-- Copyright   :  (c) Roland C. Dowdeswell <elric@imrryr.org>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Roland C. Dowdeswell <elric@imrryr.org>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Refresh window borders from the @_QUBES_LABEL_COLOR@ property set by
-- Qubes OS so focused and unfocused windows match their qube label.
--
-----------------------------------------------------------------------------
module XMonad.Hooks.Qubes
    ( -- * Usage
      -- $usage
      qubesLogHook
    ) where

import Data.Bits
import Foreign.C.Types (CLong)

import           XMonad
import qualified XMonad.StackSet as W

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad
-- > import XMonad.Hooks.Qubes
-- >
-- > main = xmonad def
-- >     { logHook = qubesLogHook
-- >     }

-- | Refresh visible window borders using their Qubes label colours.
qubesLogHook :: X ()
qubesLogHook :: X ()
qubesLogHook = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
s -> forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    let visibleWins :: [Pixel]
visibleWins = (forall a. Maybe (Stack a) -> [a]
W.integrate' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall a b. (a -> b) -> a -> b
$ WindowSet
s)
                   forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Maybe (Stack a) -> [a]
W.integrate' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace)
                                (forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
W.visible WindowSet
s)
        focused :: Maybe Pixel
focused = forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
s
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> Maybe Pixel -> Pixel -> X ()
setQubesBorder Display
d Maybe Pixel
focused) [Pixel]
visibleWins

setQubesBorder :: Display -> Maybe Window -> Window -> X ()
setQubesBorder :: Display -> Maybe Pixel -> Pixel -> X ()
setQubesBorder Display
d Maybe Pixel
focused Pixel
w = do
    Maybe [CLong]
s <- Display -> Pixel -> WorkspaceId -> X (Maybe [CLong])
getCardinalProperty Display
d Pixel
w WorkspaceId
"_QUBES_LABEL_COLOR"
    let border :: Pixel
border = Maybe [CLong] -> Maybe Pixel -> Pixel -> Pixel
qubesBorderColour Maybe [CLong]
s Maybe Pixel
focused Pixel
w
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Pixel -> IO ()
setWindowBorder Display
d Pixel
w Pixel
border

qubesBorderColour :: Maybe [CLong] -> Maybe Window -> Window -> Pixel
qubesBorderColour :: Maybe [CLong] -> Maybe Pixel -> Pixel -> Pixel
qubesBorderColour Maybe [CLong]
s Maybe Pixel
focused Pixel
w =
    Maybe [CLong] -> EventType -> Pixel
getColour Maybe [CLong]
s (if forall a. a -> Maybe a
Just Pixel
w forall a. Eq a => a -> a -> Bool
== Maybe Pixel
focused then EventType
focusIn else EventType
focusOut)

fadeByte :: Int -> Pixel -> Pixel
fadeByte :: Int -> Pixel -> Pixel
fadeByte Int
sw Pixel
c = (Pixel
0x7f forall a. Bits a => a -> a -> a
.&. Pixel
c forall a. Bits a => a -> Int -> a
`shiftR` (Int
sw forall a. Num a => a -> a -> a
+ Int
1)) forall a. Bits a => a -> Int -> a
`shiftL` Int
sw

fadeColour :: EventType -> Pixel -> Pixel
fadeColour :: EventType -> Pixel -> Pixel
fadeColour EventType
f Pixel
c
    | EventType
f forall a. Eq a => a -> a -> Bool
== EventType
focusIn = Pixel
c
    | Bool
otherwise = Int -> Pixel -> Pixel
fadeByte Int
16 Pixel
c forall a. Bits a => a -> a -> a
.|. Int -> Pixel -> Pixel
fadeByte Int
8 Pixel
c forall a. Bits a => a -> a -> a
.|. Int -> Pixel -> Pixel
fadeByte Int
0 Pixel
c

getColour :: Maybe [CLong] -> EventType -> Pixel
getColour :: Maybe [CLong] -> EventType -> Pixel
getColour (Just [CLong
s]) EventType
f = EventType -> Pixel -> Pixel
fadeColour EventType
f (forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
s)
getColour Maybe [CLong]
_ EventType
_ = Pixel
0x000000

getCardinalProperty :: Display -> Window -> String -> X (Maybe [CLong])
getCardinalProperty :: Display -> Pixel -> WorkspaceId -> X (Maybe [CLong])
getCardinalProperty Display
d Pixel
w WorkspaceId
p = do
    Pixel
a <- WorkspaceId -> X Pixel
getAtom WorkspaceId
p
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Pixel -> IO (Maybe [CLong])
getWindowProperty32 Display
d Pixel
a Pixel
w