{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards         #-}
{-# LANGUAGE CPP                   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.ShowWName
-- Description :  A layout modifier that will show the workspace name.
-- Copyright   :  (c) Andrea Rossato 2007
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- This is a layout modifier that will show the workspace name
-----------------------------------------------------------------------------

module XMonad.Layout.ShowWName
    ( -- * Usage
      -- $usage
      showWName
    , showWName'
    , def
    , SWNConfig(..)
    , ShowWName
    ) where

import XMonad
import qualified XMonad.StackSet as S
import XMonad.Layout.LayoutModifier
import XMonad.Util.Font
import XMonad.Util.Timer
import XMonad.Util.XUtils

-- $usage
-- You can use this module with the following in your
-- @xmonad.hs@:
--
-- > import XMonad.Layout.ShowWName
-- > myLayout = layoutHook def
-- > main = xmonad def { layoutHook = showWName myLayout }
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "XMonad.Doc.Extending#Editing_the_layout_hook".

-- | A layout modifier to show the workspace name when switching
showWName :: l a -> ModifiedLayout ShowWName l a
showWName :: forall (l :: * -> *) a. l a -> ModifiedLayout ShowWName l a
showWName = ShowWName a -> l a -> ModifiedLayout ShowWName l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Bool -> SWNConfig -> ShowWNState -> ShowWName a
forall a. Bool -> SWNConfig -> ShowWNState -> ShowWName a
SWN Bool
True SWNConfig
forall a. Default a => a
def ShowWNState
forall a. Maybe a
Nothing)

-- | A layout modifier to show the workspace name when switching. It
-- is possible to provide a custom configuration.
showWName' :: SWNConfig -> l a -> ModifiedLayout ShowWName l a
showWName' :: forall (l :: * -> *) a.
SWNConfig -> l a -> ModifiedLayout ShowWName l a
showWName' SWNConfig
c = ShowWName a -> l a -> ModifiedLayout ShowWName l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Bool -> SWNConfig -> ShowWNState -> ShowWName a
forall a. Bool -> SWNConfig -> ShowWNState -> ShowWName a
SWN Bool
True SWNConfig
c ShowWNState
forall a. Maybe a
Nothing)

type ShowWNState = Maybe (TimerId, Window)
data ShowWName a = SWN Bool SWNConfig ShowWNState deriving (ReadPrec [ShowWName a]
ReadPrec (ShowWName a)
Int -> ReadS (ShowWName a)
ReadS [ShowWName a]
(Int -> ReadS (ShowWName a))
-> ReadS [ShowWName a]
-> ReadPrec (ShowWName a)
-> ReadPrec [ShowWName a]
-> Read (ShowWName a)
forall a. ReadPrec [ShowWName a]
forall a. ReadPrec (ShowWName a)
forall a. Int -> ReadS (ShowWName a)
forall a. ReadS [ShowWName a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (ShowWName a)
readsPrec :: Int -> ReadS (ShowWName a)
$creadList :: forall a. ReadS [ShowWName a]
readList :: ReadS [ShowWName a]
$creadPrec :: forall a. ReadPrec (ShowWName a)
readPrec :: ReadPrec (ShowWName a)
$creadListPrec :: forall a. ReadPrec [ShowWName a]
readListPrec :: ReadPrec [ShowWName a]
Read, Int -> ShowWName a -> ShowS
[ShowWName a] -> ShowS
ShowWName a -> String
(Int -> ShowWName a -> ShowS)
-> (ShowWName a -> String)
-> ([ShowWName a] -> ShowS)
-> Show (ShowWName a)
forall a. Int -> ShowWName a -> ShowS
forall a. [ShowWName a] -> ShowS
forall a. ShowWName a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> ShowWName a -> ShowS
showsPrec :: Int -> ShowWName a -> ShowS
$cshow :: forall a. ShowWName a -> String
show :: ShowWName a -> String
$cshowList :: forall a. [ShowWName a] -> ShowS
showList :: [ShowWName a] -> ShowS
Show)

data SWNConfig =
    SWNC { SWNConfig -> String
swn_font    :: String   -- ^ Font name
         , SWNConfig -> String
swn_bgcolor :: String   -- ^ Background color
         , SWNConfig -> String
swn_color   :: String   -- ^ String color
         , SWNConfig -> Rational
swn_fade    :: Rational -- ^ Time in seconds of the name visibility
    } deriving (ReadPrec [SWNConfig]
ReadPrec SWNConfig
Int -> ReadS SWNConfig
ReadS [SWNConfig]
(Int -> ReadS SWNConfig)
-> ReadS [SWNConfig]
-> ReadPrec SWNConfig
-> ReadPrec [SWNConfig]
-> Read SWNConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SWNConfig
readsPrec :: Int -> ReadS SWNConfig
$creadList :: ReadS [SWNConfig]
readList :: ReadS [SWNConfig]
$creadPrec :: ReadPrec SWNConfig
readPrec :: ReadPrec SWNConfig
$creadListPrec :: ReadPrec [SWNConfig]
readListPrec :: ReadPrec [SWNConfig]
Read, Int -> SWNConfig -> ShowS
[SWNConfig] -> ShowS
SWNConfig -> String
(Int -> SWNConfig -> ShowS)
-> (SWNConfig -> String)
-> ([SWNConfig] -> ShowS)
-> Show SWNConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SWNConfig -> ShowS
showsPrec :: Int -> SWNConfig -> ShowS
$cshow :: SWNConfig -> String
show :: SWNConfig -> String
$cshowList :: [SWNConfig] -> ShowS
showList :: [SWNConfig] -> ShowS
Show)

instance Default SWNConfig where
  def :: SWNConfig
def =
#ifdef XFT
    SWNC { swn_font :: String
swn_font    = String
"xft:monospace-20"
#else
    SWNC { swn_font    = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
#endif
         , swn_bgcolor :: String
swn_bgcolor = String
"black"
         , swn_color :: String
swn_color   = String
"white"
         , swn_fade :: Rational
swn_fade    = Rational
1
         }

instance LayoutModifier ShowWName a where
    redoLayout :: ShowWName a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
redoLayout      ShowWName a
sn Rectangle
r Maybe (Stack a)
_ = ShowWName a
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a.
ShowWName a
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
doShow ShowWName a
sn Rectangle
r

    handleMess :: ShowWName a -> SomeMessage -> X (Maybe (ShowWName a))
handleMess (SWN Bool
_ SWNConfig
c (Just (Int
i,Window
w))) SomeMessage
m
        | Just Event
e    <- SomeMessage -> Maybe Event
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = Int -> Event -> X (Maybe (ShowWName a)) -> X (Maybe (ShowWName a))
forall a. Int -> Event -> X (Maybe a) -> X (Maybe a)
handleTimer Int
i Event
e (Window -> X ()
deleteWindow Window
w X () -> X (Maybe (ShowWName a)) -> X (Maybe (ShowWName a))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (ShowWName a) -> X (Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ShowWName a)
forall a. Maybe a
Nothing)
        | Just LayoutMessages
Hide <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do Window -> X ()
deleteWindow Window
w
                                          Maybe (ShowWName a) -> X (Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ShowWName a) -> X (Maybe (ShowWName a)))
-> (ShowWName a -> Maybe (ShowWName a))
-> ShowWName a
-> X (Maybe (ShowWName a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowWName a -> Maybe (ShowWName a)
forall a. a -> Maybe a
Just (ShowWName a -> X (Maybe (ShowWName a)))
-> ShowWName a -> X (Maybe (ShowWName a))
forall a b. (a -> b) -> a -> b
$ Bool -> SWNConfig -> ShowWNState -> ShowWName a
forall a. Bool -> SWNConfig -> ShowWNState -> ShowWName a
SWN Bool
True SWNConfig
c ShowWNState
forall a. Maybe a
Nothing

    handleMess (SWN Bool
_ SWNConfig
c ShowWNState
s) SomeMessage
m
        | Just LayoutMessages
Hide <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = Maybe (ShowWName a) -> X (Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ShowWName a) -> X (Maybe (ShowWName a)))
-> (ShowWName a -> Maybe (ShowWName a))
-> ShowWName a
-> X (Maybe (ShowWName a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowWName a -> Maybe (ShowWName a)
forall a. a -> Maybe a
Just (ShowWName a -> X (Maybe (ShowWName a)))
-> ShowWName a -> X (Maybe (ShowWName a))
forall a b. (a -> b) -> a -> b
$ Bool -> SWNConfig -> ShowWNState -> ShowWName a
forall a. Bool -> SWNConfig -> ShowWNState -> ShowWName a
SWN Bool
True SWNConfig
c ShowWNState
s
        | Bool
otherwise                  = Maybe (ShowWName a) -> X (Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ShowWName a)
forall a. Maybe a
Nothing

doShow :: ShowWName a -> Rectangle -> [(a,Rectangle)] -> X ([(a, Rectangle)], Maybe (ShowWName a))
doShow :: forall a.
ShowWName a
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
doShow (SWN Bool
True  SWNConfig
c (Just (Int
_,Window
w))) Rectangle
r [(a, Rectangle)]
wrs = Window -> X ()
deleteWindow Window
w X ()
-> X ([(a, Rectangle)], Maybe (ShowWName a))
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SWNConfig
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a.
SWNConfig
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
flashName SWNConfig
c Rectangle
r [(a, Rectangle)]
wrs
doShow (SWN Bool
True  SWNConfig
c  ShowWNState
Nothing    ) Rectangle
r [(a, Rectangle)]
wrs = SWNConfig
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a.
SWNConfig
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
flashName SWNConfig
c Rectangle
r [(a, Rectangle)]
wrs
doShow (SWN Bool
False SWNConfig
_  ShowWNState
_          ) Rectangle
_ [(a, Rectangle)]
wrs = ([(a, Rectangle)], Maybe (ShowWName a))
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, Maybe (ShowWName a)
forall a. Maybe a
Nothing)

flashName :: SWNConfig -> Rectangle -> [(a, Rectangle)] -> X ([(a, Rectangle)], Maybe (ShowWName a))
flashName :: forall a.
SWNConfig
-> Rectangle
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (ShowWName a))
flashName SWNConfig
c (Rectangle Position
sx Position
sy Dimension
wh Dimension
ht) [(a, Rectangle)]
wrs = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  String
n <- (WindowSet -> X String) -> X String
forall a. (WindowSet -> X a) -> X a
withWindowSet (String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String)
-> (WindowSet -> String) -> WindowSet -> X String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
S.currentTag)
  XMonadFont
f <- String -> X XMonadFont
initXMF (SWNConfig -> String
swn_font SWNConfig
c)
  Int
width <- (\Int
w -> Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n) (Int -> Int) -> X Int -> X Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> XMonadFont -> String -> X Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
d XMonadFont
f String
n
  (Position
as,Position
ds) <- XMonadFont -> String -> X (Position, Position)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
f String
n
  let hight :: Position
hight = Position
as Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
ds
      y :: Position
y     = Position -> Position
forall a b. (Integral a, Num b) => a -> b
fi Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
hight Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
2) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
      x :: Int
x     = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi Position
sx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
wh Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  Window
w <- Rectangle -> Maybe Window -> String -> Bool -> X Window
createNewWindow (Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
x) (Position -> Position
forall a b. (Integral a, Num b) => a -> b
fi Position
y) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
width) (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
hight)) Maybe Window
forall a. Maybe a
Nothing String
"" Bool
True
  Window -> X ()
showWindow Window
w
  Window
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> X ()
paintAndWrite Window
w XMonadFont
f (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
width) (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
hight) Dimension
0 (SWNConfig -> String
swn_bgcolor SWNConfig
c) String
"" (SWNConfig -> String
swn_color SWNConfig
c) (SWNConfig -> String
swn_bgcolor SWNConfig
c) [Align
AlignCenter] [String
n]
  XMonadFont -> X ()
releaseXMF XMonadFont
f
  Int
i <- Rational -> X Int
startTimer (SWNConfig -> Rational
swn_fade SWNConfig
c)
  ([(a, Rectangle)], Maybe (ShowWName a))
-> X ([(a, Rectangle)], Maybe (ShowWName a))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, ShowWName a -> Maybe (ShowWName a)
forall a. a -> Maybe a
Just (ShowWName a -> Maybe (ShowWName a))
-> ShowWName a -> Maybe (ShowWName a)
forall a b. (a -> b) -> a -> b
$ Bool -> SWNConfig -> ShowWNState -> ShowWName a
forall a. Bool -> SWNConfig -> ShowWNState -> ShowWName a
SWN Bool
False SWNConfig
c (ShowWNState -> ShowWName a) -> ShowWNState -> ShowWName a
forall a b. (a -> b) -> a -> b
$ (Int, Window) -> ShowWNState
forall a. a -> Maybe a
Just (Int
i,Window
w))