-----------------------------------
-- |
-- Module      : XMonad.Hooks.WallpaperSetter
-- Description : Change the wallpapers depending on visible workspaces.
-- Copyright   : (c) Anton Pirogov, 2014
-- License     : BSD3
--
-- Maintainer  : Anton Pirogov <anton.pirogov@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Log hook which changes the wallpapers depending on visible workspaces.
-----------------------------------
module XMonad.Hooks.WallpaperSetter (
  -- * Usage
  -- $usage
  wallpaperSetter
, WallpaperConf(..)
, Wallpaper(..)
, WallpaperList(..)
, defWallpaperConf
, defWPNamesJpg, defWPNamesPng, defWPNames
  -- *TODO
  -- $todo
) where
import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as S
import qualified XMonad.Util.ExtensibleState as XS

import System.IO
import System.Process
import System.Directory (getHomeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>))
import System.Random (randomRIO)

import qualified Data.Map as M

-- $usage
-- This module requires imagemagick and feh to be installed, as these are utilized
-- for the required image transformations and the actual setting of the wallpaper.
--
-- This was especially tested with multi-head setups - if you have two monitors and swap
-- the workspaces, the wallpapers will be swapped too, scaled accordingly and rotated if necessary
-- (e.g. if you are using your monitor rotated but only have wide wallpapers).
--
-- Add a log hook like this:
--
-- > myWorkspaces = ["1:main","2:misc","3","4"]
-- > ...
-- > main = xmonad $ def {
-- >   logHook = wallpaperSetter defWallpaperConf {
-- >                                wallpapers = defWPNames myWorkspaces
-- >                                          <> WallpaperList [("1:main",WallpaperDir "1")]
-- >                             }
-- >   }
-- > ...

-- $todo
-- * implement a kind of image cache like in wallpaperd to remove or at least reduce the lag
--
-- * find out how to merge multiple images from stdin to one (-> for caching all pictures in memory)

-- | internal. to use XMonad state for memory in-between log-hook calls and remember PID of old external call
data WCState = WCState (Maybe [WorkspaceId]) (Maybe ProcessHandle)
instance ExtensionClass WCState where
  initialValue :: WCState
initialValue = Maybe [WorkspaceId] -> Maybe ProcessHandle -> WCState
WCState Maybe [WorkspaceId]
forall a. Maybe a
Nothing Maybe ProcessHandle
forall a. Maybe a
Nothing

-- | Represents a wallpaper
data Wallpaper = WallpaperFix FilePath -- ^ Single, fixed wallpaper
               | WallpaperDir FilePath -- ^ Random wallpaper from this subdirectory
               deriving (Wallpaper -> Wallpaper -> Bool
(Wallpaper -> Wallpaper -> Bool)
-> (Wallpaper -> Wallpaper -> Bool) -> Eq Wallpaper
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Wallpaper -> Wallpaper -> Bool
$c/= :: Wallpaper -> Wallpaper -> Bool
== :: Wallpaper -> Wallpaper -> Bool
$c== :: Wallpaper -> Wallpaper -> Bool
Eq, Int -> Wallpaper -> ShowS
[Wallpaper] -> ShowS
Wallpaper -> WorkspaceId
(Int -> Wallpaper -> ShowS)
-> (Wallpaper -> WorkspaceId)
-> ([Wallpaper] -> ShowS)
-> Show Wallpaper
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [Wallpaper] -> ShowS
$cshowList :: [Wallpaper] -> ShowS
show :: Wallpaper -> WorkspaceId
$cshow :: Wallpaper -> WorkspaceId
showsPrec :: Int -> Wallpaper -> ShowS
$cshowsPrec :: Int -> Wallpaper -> ShowS
Show, ReadPrec [Wallpaper]
ReadPrec Wallpaper
Int -> ReadS Wallpaper
ReadS [Wallpaper]
(Int -> ReadS Wallpaper)
-> ReadS [Wallpaper]
-> ReadPrec Wallpaper
-> ReadPrec [Wallpaper]
-> Read Wallpaper
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Wallpaper]
$creadListPrec :: ReadPrec [Wallpaper]
readPrec :: ReadPrec Wallpaper
$creadPrec :: ReadPrec Wallpaper
readList :: ReadS [Wallpaper]
$creadList :: ReadS [Wallpaper]
readsPrec :: Int -> ReadS Wallpaper
$creadsPrec :: Int -> ReadS Wallpaper
Read)

newtype WallpaperList = WallpaperList [(WorkspaceId, Wallpaper)]
  deriving (Int -> WallpaperList -> ShowS
[WallpaperList] -> ShowS
WallpaperList -> WorkspaceId
(Int -> WallpaperList -> ShowS)
-> (WallpaperList -> WorkspaceId)
-> ([WallpaperList] -> ShowS)
-> Show WallpaperList
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WallpaperList] -> ShowS
$cshowList :: [WallpaperList] -> ShowS
show :: WallpaperList -> WorkspaceId
$cshow :: WallpaperList -> WorkspaceId
showsPrec :: Int -> WallpaperList -> ShowS
$cshowsPrec :: Int -> WallpaperList -> ShowS
Show,ReadPrec [WallpaperList]
ReadPrec WallpaperList
Int -> ReadS WallpaperList
ReadS [WallpaperList]
(Int -> ReadS WallpaperList)
-> ReadS [WallpaperList]
-> ReadPrec WallpaperList
-> ReadPrec [WallpaperList]
-> Read WallpaperList
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WallpaperList]
$creadListPrec :: ReadPrec [WallpaperList]
readPrec :: ReadPrec WallpaperList
$creadPrec :: ReadPrec WallpaperList
readList :: ReadS [WallpaperList]
$creadList :: ReadS [WallpaperList]
readsPrec :: Int -> ReadS WallpaperList
$creadsPrec :: Int -> ReadS WallpaperList
Read)

instance Semigroup WallpaperList where
  WallpaperList [(WorkspaceId, Wallpaper)]
w1 <> :: WallpaperList -> WallpaperList -> WallpaperList
<> WallpaperList [(WorkspaceId, Wallpaper)]
w2 =
    [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList ([(WorkspaceId, Wallpaper)] -> WallpaperList)
-> [(WorkspaceId, Wallpaper)] -> WallpaperList
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId Wallpaper -> [(WorkspaceId, Wallpaper)]
forall k a. Map k a -> [(k, a)]
M.toList (Map WorkspaceId Wallpaper -> [(WorkspaceId, Wallpaper)])
-> Map WorkspaceId Wallpaper -> [(WorkspaceId, Wallpaper)]
forall a b. (a -> b) -> a -> b
$ [(WorkspaceId, Wallpaper)] -> Map WorkspaceId Wallpaper
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(WorkspaceId, Wallpaper)]
w2 Map WorkspaceId Wallpaper
-> Map WorkspaceId Wallpaper -> Map WorkspaceId Wallpaper
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` [(WorkspaceId, Wallpaper)] -> Map WorkspaceId Wallpaper
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(WorkspaceId, Wallpaper)]
w1

instance Monoid WallpaperList where
  mempty :: WallpaperList
mempty = [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList []

-- | Complete wallpaper configuration passed to the hook
data WallpaperConf = WallpaperConf {
    WallpaperConf -> WorkspaceId
wallpaperBaseDir :: FilePath  -- ^ Where the wallpapers reside (if empty, will look in \~\/.wallpapers/)
  , WallpaperConf -> WallpaperList
wallpapers :: WallpaperList   -- ^ List of the wallpaper associations for workspaces
  } deriving (Int -> WallpaperConf -> ShowS
[WallpaperConf] -> ShowS
WallpaperConf -> WorkspaceId
(Int -> WallpaperConf -> ShowS)
-> (WallpaperConf -> WorkspaceId)
-> ([WallpaperConf] -> ShowS)
-> Show WallpaperConf
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WallpaperConf] -> ShowS
$cshowList :: [WallpaperConf] -> ShowS
show :: WallpaperConf -> WorkspaceId
$cshow :: WallpaperConf -> WorkspaceId
showsPrec :: Int -> WallpaperConf -> ShowS
$cshowsPrec :: Int -> WallpaperConf -> ShowS
Show, ReadPrec [WallpaperConf]
ReadPrec WallpaperConf
Int -> ReadS WallpaperConf
ReadS [WallpaperConf]
(Int -> ReadS WallpaperConf)
-> ReadS [WallpaperConf]
-> ReadPrec WallpaperConf
-> ReadPrec [WallpaperConf]
-> Read WallpaperConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WallpaperConf]
$creadListPrec :: ReadPrec [WallpaperConf]
readPrec :: ReadPrec WallpaperConf
$creadPrec :: ReadPrec WallpaperConf
readList :: ReadS [WallpaperConf]
$creadList :: ReadS [WallpaperConf]
readsPrec :: Int -> ReadS WallpaperConf
$creadsPrec :: Int -> ReadS WallpaperConf
Read)

-- | default configuration. looks in \~\/.wallpapers/ for WORKSPACEID.jpg
defWallpaperConf :: WallpaperConf
defWallpaperConf :: WallpaperConf
defWallpaperConf = WorkspaceId -> WallpaperList -> WallpaperConf
WallpaperConf WorkspaceId
"" (WallpaperList -> WallpaperConf) -> WallpaperList -> WallpaperConf
forall a b. (a -> b) -> a -> b
$ [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList []

instance Default WallpaperConf where
    def :: WallpaperConf
def = WallpaperConf
defWallpaperConf

{-# DEPRECATED defWPNames "Use defWPNamesJpg instead" #-}
defWPNames :: [WorkspaceId] -> WallpaperList
defWPNames :: [WorkspaceId] -> WallpaperList
defWPNames = [WorkspaceId] -> WallpaperList
defWPNamesJpg

-- | Return the default association list (maps @name@ to @name.jpg@, non-alphanumeric characters are omitted)
defWPNamesJpg :: [WorkspaceId] -> WallpaperList
defWPNamesJpg :: [WorkspaceId] -> WallpaperList
defWPNamesJpg [WorkspaceId]
xs = [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList ([(WorkspaceId, Wallpaper)] -> WallpaperList)
-> [(WorkspaceId, Wallpaper)] -> WallpaperList
forall a b. (a -> b) -> a -> b
$ (WorkspaceId -> (WorkspaceId, Wallpaper))
-> [WorkspaceId] -> [(WorkspaceId, Wallpaper)]
forall a b. (a -> b) -> [a] -> [b]
map (\WorkspaceId
x -> (WorkspaceId
x, WorkspaceId -> Wallpaper
WallpaperFix ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum WorkspaceId
x WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
".jpg"))) [WorkspaceId]
xs

-- | Like 'defWPNamesJpg', but map @name@ to @name.png@ instead.
defWPNamesPng :: [WorkspaceId] -> WallpaperList
defWPNamesPng :: [WorkspaceId] -> WallpaperList
defWPNamesPng [WorkspaceId]
xs = [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList ([(WorkspaceId, Wallpaper)] -> WallpaperList)
-> [(WorkspaceId, Wallpaper)] -> WallpaperList
forall a b. (a -> b) -> a -> b
$ (WorkspaceId -> (WorkspaceId, Wallpaper))
-> [WorkspaceId] -> [(WorkspaceId, Wallpaper)]
forall a b. (a -> b) -> [a] -> [b]
map (\WorkspaceId
x -> (WorkspaceId
x, WorkspaceId -> Wallpaper
WallpaperFix ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum WorkspaceId
x WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
".png"))) [WorkspaceId]
xs

-- | Add this to your log hook with the workspace configuration as argument.
wallpaperSetter :: WallpaperConf -> X ()
wallpaperSetter :: WallpaperConf -> X ()
wallpaperSetter WallpaperConf
wpconf = do
  WCState Maybe [WorkspaceId]
oldws Maybe ProcessHandle
h <- X WCState
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  [WorkspaceId]
visws <- X [WorkspaceId]
getVisibleWorkspaces
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([WorkspaceId] -> Maybe [WorkspaceId]
forall a. a -> Maybe a
Just [WorkspaceId]
visws Maybe [WorkspaceId] -> Maybe [WorkspaceId] -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe [WorkspaceId]
oldws) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do

    WallpaperConf
wpconf' <- WallpaperConf -> X WallpaperConf
completeWPConf WallpaperConf
wpconf
    [(Rectangle, WorkspaceId)]
wspicpaths <- WallpaperConf -> X [(Rectangle, WorkspaceId)]
getPicPathsAndWSRects WallpaperConf
wpconf'

    -- terminate old call if any to prevent unnecessary CPU overload when switching WS too fast
    case Maybe ProcessHandle
h of
      Maybe ProcessHandle
Nothing -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ProcessHandle
pid -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid

    ProcessHandle
handle <- [(Rectangle, WorkspaceId)] -> X ProcessHandle
applyWallpaper [(Rectangle, WorkspaceId)]
wspicpaths
    WCState -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WCState -> X ()) -> WCState -> X ()
forall a b. (a -> b) -> a -> b
$ Maybe [WorkspaceId] -> Maybe ProcessHandle -> WCState
WCState ([WorkspaceId] -> Maybe [WorkspaceId]
forall a. a -> Maybe a
Just [WorkspaceId]
visws) (Maybe ProcessHandle -> WCState) -> Maybe ProcessHandle -> WCState
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
handle

-- Helper functions
-------------------

-- | Picks a random element from a list
pickFrom :: [a] -> IO a
pickFrom :: forall a. [a] -> IO a
pickFrom [a]
list = do
  Int
i <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0,[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
list [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i

-- | get absolute picture path of the given wallpaper picture
-- or select a random one if it is a directory
getPicPath :: WallpaperConf -> Wallpaper -> IO (Maybe FilePath)
getPicPath :: WallpaperConf -> Wallpaper -> IO (Maybe WorkspaceId)
getPicPath WallpaperConf
conf (WallpaperDir WorkspaceId
dir) = do
  Bool
direxists <- WorkspaceId -> IO Bool
doesDirectoryExist (WorkspaceId -> IO Bool) -> WorkspaceId -> IO Bool
forall a b. (a -> b) -> a -> b
$ WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
dir
  if Bool
direxists
    then do [WorkspaceId]
files <- WorkspaceId -> IO [WorkspaceId]
getDirectoryContents (WorkspaceId -> IO [WorkspaceId])
-> WorkspaceId -> IO [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
dir
            let files' :: [WorkspaceId]
files' = (WorkspaceId -> Bool) -> [WorkspaceId] -> [WorkspaceId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.')(Char -> Bool) -> (WorkspaceId -> Char) -> WorkspaceId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.WorkspaceId -> Char
forall a. [a] -> a
head) [WorkspaceId]
files
            WorkspaceId
file <- [WorkspaceId] -> IO WorkspaceId
forall a. [a] -> IO a
pickFrom [WorkspaceId]
files'
            Maybe WorkspaceId -> IO (Maybe WorkspaceId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe WorkspaceId -> IO (Maybe WorkspaceId))
-> Maybe WorkspaceId -> IO (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> Maybe WorkspaceId
forall a. a -> Maybe a
Just (WorkspaceId -> Maybe WorkspaceId)
-> WorkspaceId -> Maybe WorkspaceId
forall a b. (a -> b) -> a -> b
$ WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
dir WorkspaceId -> ShowS
</> WorkspaceId
file
    else Maybe WorkspaceId -> IO (Maybe WorkspaceId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WorkspaceId
forall a. Maybe a
Nothing
getPicPath WallpaperConf
conf (WallpaperFix WorkspaceId
file) = do
  Bool
exist <- WorkspaceId -> IO Bool
doesFileExist WorkspaceId
path
  Maybe WorkspaceId -> IO (Maybe WorkspaceId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe WorkspaceId -> IO (Maybe WorkspaceId))
-> Maybe WorkspaceId -> IO (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ if Bool
exist then WorkspaceId -> Maybe WorkspaceId
forall a. a -> Maybe a
Just WorkspaceId
path else Maybe WorkspaceId
forall a. Maybe a
Nothing
  where path :: WorkspaceId
path = WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
file

-- | Take a path to a picture, return (width, height) if the path is a valid picture
-- (requires imagemagick tool identify to be installed)
getPicRes :: FilePath -> IO (Maybe (Int,Int))
getPicRes :: WorkspaceId -> IO (Maybe (Int, Int))
getPicRes WorkspaceId
picpath = do
  (Maybe Handle
_, Just Handle
outh,Maybe Handle
_,ProcessHandle
_pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (WorkspaceId -> [WorkspaceId] -> CreateProcess
proc WorkspaceId
"identify" [WorkspaceId
"-format", WorkspaceId
"%w %h", WorkspaceId
picpath]) { std_out :: StdStream
std_out = StdStream
CreatePipe }
  WorkspaceId
output <- Handle -> IO WorkspaceId
hGetContents Handle
outh
  Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, Int) -> IO (Maybe (Int, Int)))
-> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ case (WorkspaceId -> [(Int, WorkspaceId)])
-> [WorkspaceId] -> [[(Int, WorkspaceId)]]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceId -> [(Int, WorkspaceId)]
forall a. Read a => ReadS a
reads (WorkspaceId -> [WorkspaceId]
words WorkspaceId
output) of
    -- mapM Text.Read.readMaybe is better but only in ghc>=7.6
    [[(Int
w,WorkspaceId
"")],[(Int
h,WorkspaceId
"")]] -> (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
w,Int
h)
    [[(Int, WorkspaceId)]]
_ -> Maybe (Int, Int)
forall a. Maybe a
Nothing

-- |complete unset fields to default values (wallpaper directory = ~/.wallpapers,
--  expects a file "NAME.jpg" for each workspace named NAME)
completeWPConf :: WallpaperConf -> X WallpaperConf
completeWPConf :: WallpaperConf -> X WallpaperConf
completeWPConf (WallpaperConf WorkspaceId
dir (WallpaperList [(WorkspaceId, Wallpaper)]
ws)) = do
  WorkspaceId
home <- IO WorkspaceId -> X WorkspaceId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WorkspaceId
getHomeDirectory
  WindowSet
winset <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  let tags :: [WorkspaceId]
tags = (Workspace WorkspaceId (Layout Window) Window -> WorkspaceId)
-> [Workspace WorkspaceId (Layout Window) Window] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map Workspace WorkspaceId (Layout Window) Window -> WorkspaceId
forall i l a. Workspace i l a -> i
S.tag ([Workspace WorkspaceId (Layout Window) Window] -> [WorkspaceId])
-> [Workspace WorkspaceId (Layout Window) Window] -> [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Workspace WorkspaceId (Layout Window) Window]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
S.workspaces WindowSet
winset
      dir' :: WorkspaceId
dir' = if WorkspaceId -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null WorkspaceId
dir then WorkspaceId
home WorkspaceId -> ShowS
</> WorkspaceId
".wallpapers" else WorkspaceId
dir
      ws' :: WallpaperList
ws'  = if [(WorkspaceId, Wallpaper)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(WorkspaceId, Wallpaper)]
ws then [WorkspaceId] -> WallpaperList
defWPNames [WorkspaceId]
tags else [(WorkspaceId, Wallpaper)] -> WallpaperList
WallpaperList [(WorkspaceId, Wallpaper)]
ws
  WallpaperConf -> X WallpaperConf
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId -> WallpaperList -> WallpaperConf
WallpaperConf WorkspaceId
dir' WallpaperList
ws')

getVisibleWorkspaces :: X [WorkspaceId]
getVisibleWorkspaces :: X [WorkspaceId]
getVisibleWorkspaces = do
  WindowSet
winset <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  [WorkspaceId] -> X [WorkspaceId]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WorkspaceId] -> X [WorkspaceId])
-> [WorkspaceId] -> X [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> WorkspaceId)
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (Workspace WorkspaceId (Layout Window) Window -> WorkspaceId
forall i l a. Workspace i l a -> i
S.tag (Workspace WorkspaceId (Layout Window) Window -> WorkspaceId)
-> (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Window) Window)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
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
S.workspace) ([Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
 -> [WorkspaceId])
-> ([Screen
       WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
    -> [Screen
          WorkspaceId (Layout Window) Window ScreenId ScreenDetail])
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [WorkspaceId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> ScreenId)
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
S.screen ([Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
 -> [WorkspaceId])
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ WindowSet
-> 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
S.current WindowSet
winset Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [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]
S.visible WindowSet
winset

getPicPathsAndWSRects :: WallpaperConf -> X [(Rectangle, FilePath)]
getPicPathsAndWSRects :: WallpaperConf -> X [(Rectangle, WorkspaceId)]
getPicPathsAndWSRects WallpaperConf
wpconf = do
  WindowSet
winset <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  [(WorkspaceId, Maybe WorkspaceId)]
paths <- IO [(WorkspaceId, Maybe WorkspaceId)]
-> X [(WorkspaceId, Maybe WorkspaceId)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(WorkspaceId, Maybe WorkspaceId)]
getPicPaths
  [WorkspaceId]
visws <- X [WorkspaceId]
getVisibleWorkspaces
  let visscr :: [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
visscr = WindowSet
-> 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
S.current WindowSet
winset Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
forall a. a -> [a] -> [a]
: WindowSet
-> [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]
S.visible WindowSet
winset
      visrects :: Map WorkspaceId ScreenDetail
visrects = [(WorkspaceId, ScreenDetail)] -> Map WorkspaceId ScreenDetail
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(WorkspaceId, ScreenDetail)] -> Map WorkspaceId ScreenDetail)
-> [(WorkspaceId, ScreenDetail)] -> Map WorkspaceId ScreenDetail
forall a b. (a -> b) -> a -> b
$ (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> (WorkspaceId, ScreenDetail))
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [(WorkspaceId, ScreenDetail)]
forall a b. (a -> b) -> [a] -> [b]
map (\Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
x -> ((Workspace WorkspaceId (Layout Window) Window -> WorkspaceId
forall i l a. Workspace i l a -> i
S.tag (Workspace WorkspaceId (Layout Window) Window -> WorkspaceId)
-> (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
    -> Workspace WorkspaceId (Layout Window) Window)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
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
S.workspace) Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
x, Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
S.screenDetail Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
x)) [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
visscr
      getRect :: WorkspaceId -> Rectangle
getRect WorkspaceId
tag = ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle) -> ScreenDetail -> Rectangle
forall a b. (a -> b) -> a -> b
$ Maybe ScreenDetail -> ScreenDetail
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ScreenDetail -> ScreenDetail)
-> Maybe ScreenDetail -> ScreenDetail
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> Map WorkspaceId ScreenDetail -> Maybe ScreenDetail
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
tag Map WorkspaceId ScreenDetail
visrects
      foundpaths :: [(Rectangle, WorkspaceId)]
foundpaths = [ (WorkspaceId -> Rectangle
getRect WorkspaceId
n, WorkspaceId
p) | (WorkspaceId
n, Just WorkspaceId
p) <- [(WorkspaceId, Maybe WorkspaceId)]
paths, WorkspaceId
n WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
visws ]
  [(Rectangle, WorkspaceId)] -> X [(Rectangle, WorkspaceId)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Rectangle, WorkspaceId)]
foundpaths
  where getPicPaths :: IO [(WorkspaceId, Maybe WorkspaceId)]
getPicPaths = ((WorkspaceId, Wallpaper) -> IO (WorkspaceId, Maybe WorkspaceId))
-> [(WorkspaceId, Wallpaper)]
-> IO [(WorkspaceId, Maybe WorkspaceId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(WorkspaceId
x,Wallpaper
y) -> WallpaperConf -> Wallpaper -> IO (Maybe WorkspaceId)
getPicPath WallpaperConf
wpconf Wallpaper
y
                             IO (Maybe WorkspaceId)
-> (Maybe WorkspaceId -> IO (WorkspaceId, Maybe WorkspaceId))
-> IO (WorkspaceId, Maybe WorkspaceId)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe WorkspaceId
p -> (WorkspaceId, Maybe WorkspaceId)
-> IO (WorkspaceId, Maybe WorkspaceId)
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId
x,Maybe WorkspaceId
p)) [(WorkspaceId, Wallpaper)]
wl
        WallpaperList [(WorkspaceId, Wallpaper)]
wl   = WallpaperConf -> WallpaperList
wallpapers WallpaperConf
wpconf

-- | Gets a list of geometry rectangles and filenames, builds and sets wallpaper
applyWallpaper :: [(Rectangle, FilePath)] -> X ProcessHandle
applyWallpaper :: [(Rectangle, WorkspaceId)] -> X ProcessHandle
applyWallpaper [(Rectangle, WorkspaceId)]
parts = do
  WindowSet
winset <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  let (Integer
vx,Integer
vy) = WindowSet -> (Integer, Integer)
forall i l a sid.
StackSet i l a sid ScreenDetail -> (Integer, Integer)
getVScreenDim WindowSet
winset
  [WorkspaceId]
layers <- IO [WorkspaceId] -> X [WorkspaceId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [WorkspaceId] -> X [WorkspaceId])
-> IO [WorkspaceId] -> X [WorkspaceId]
forall a b. (a -> b) -> a -> b
$ ((Rectangle, WorkspaceId) -> IO WorkspaceId)
-> [(Rectangle, WorkspaceId)] -> IO [WorkspaceId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rectangle, WorkspaceId) -> IO WorkspaceId
layerCommand [(Rectangle, WorkspaceId)]
parts
  let basepart :: WorkspaceId
basepart =WorkspaceId
"convert -size " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show Integer
vx WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
"x" WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show Integer
vy WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" xc:black"
      endpart :: WorkspaceId
endpart =WorkspaceId
" jpg:- | feh --no-xinerama --bg-tile --no-fehbg -"
      cmd :: WorkspaceId
cmd = WorkspaceId
basepart WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ [WorkspaceId] -> WorkspaceId
unwords [WorkspaceId]
layers WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
endpart
  IO ProcessHandle -> X ProcessHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> X ProcessHandle)
-> IO ProcessHandle -> X ProcessHandle
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> IO ProcessHandle
runCommand WorkspaceId
cmd


getVScreenDim :: S.StackSet i l a sid ScreenDetail -> (Integer, Integer)
getVScreenDim :: forall i l a sid.
StackSet i l a sid ScreenDetail -> (Integer, Integer)
getVScreenDim = (Screen i l a sid ScreenDetail
 -> (Integer, Integer) -> (Integer, Integer))
-> (Integer, Integer)
-> [Screen i l a sid ScreenDetail]
-> (Integer, Integer)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Rectangle -> (Integer, Integer) -> (Integer, Integer)
forall {a} {b}.
(Ord a, Ord b, Num a, Num b) =>
Rectangle -> (a, b) -> (a, b)
maxXY (Rectangle -> (Integer, Integer) -> (Integer, Integer))
-> (Screen i l a sid ScreenDetail -> Rectangle)
-> Screen i l a sid ScreenDetail
-> (Integer, Integer)
-> (Integer, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (Screen i l a sid ScreenDetail -> ScreenDetail)
-> Screen i l a sid ScreenDetail
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen i l a sid ScreenDetail -> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
S.screenDetail) (Integer
0,Integer
0) ([Screen i l a sid ScreenDetail] -> (Integer, Integer))
-> (StackSet i l a sid ScreenDetail
    -> [Screen i l a sid ScreenDetail])
-> StackSet i l a sid ScreenDetail
-> (Integer, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet i l a sid ScreenDetail -> [Screen i l a sid ScreenDetail]
forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
S.screens
  where maxXY :: Rectangle -> (a, b) -> (a, b)
maxXY (Rectangle Position
x Position
y Dimension
w Dimension
h) (a
mx,b
my) = ( Dimension -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
xDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Dimension
w) a -> a -> a
forall a. Ord a => a -> a -> a
`max` a
mx
                                            , Dimension -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
yDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Dimension
h) b -> b -> b
forall a. Ord a => a -> a -> a
`max` b
my )

needsRotation :: Rectangle -> (Int,Int) -> Bool
needsRotation :: Rectangle -> (Int, Int) -> Bool
needsRotation Rectangle
rect (Int
px,Int
py) = let wratio, pratio :: Double
                                 wratio :: Double
wratio = Dimension -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Dimension -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_height Rectangle
rect)
                                 pratio :: Double
pratio = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
px Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
py
                             in Double
wratio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 Bool -> Bool -> Bool
&& Double
pratio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1 Bool -> Bool -> Bool
|| Double
wratio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1 Bool -> Bool -> Bool
&& Double
pratio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1

layerCommand :: (Rectangle, FilePath) -> IO String
layerCommand :: (Rectangle, WorkspaceId) -> IO WorkspaceId
layerCommand (Rectangle
rect, WorkspaceId
path) = do
  Maybe (Int, Int)
res <- WorkspaceId -> IO (Maybe (Int, Int))
getPicRes WorkspaceId
path
  WorkspaceId -> IO WorkspaceId
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId -> IO WorkspaceId) -> WorkspaceId -> IO WorkspaceId
forall a b. (a -> b) -> a -> b
$ case Rectangle -> (Int, Int) -> Bool
needsRotation Rectangle
rect ((Int, Int) -> Bool) -> Maybe (Int, Int) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, Int)
res of
    Maybe Bool
Nothing -> WorkspaceId
""
    Just Bool
rotate -> let size :: WorkspaceId
size = Dimension -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (Rectangle -> Dimension
rect_width Rectangle
rect) WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
"x" WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Dimension -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (Rectangle -> Dimension
rect_height Rectangle
rect) in
                     WorkspaceId
" \\( '"WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
pathWorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
"' "WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++(if Bool
rotate then WorkspaceId
"-rotate 90 " else WorkspaceId
"")
                      WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -scale "WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
sizeWorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
"^ -gravity center -extent "WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
sizeWorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++WorkspaceId
" +gravity \\)"
                      WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -geometry +" WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (Rectangle -> Position
rect_x Rectangle
rect) WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
"+" WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Position -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show (Rectangle -> Position
rect_y Rectangle
rect) WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -composite "