-----------------------------------
-- |
-- 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 forall a. Maybe a
Nothing 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
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
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]
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
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]
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 forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(WorkspaceId, Wallpaper)]
w2 forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` 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
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]
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
"" 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\WorkspaceId
x -> (WorkspaceId
x, WorkspaceId -> Wallpaper
WallpaperFix (forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum WorkspaceId
x 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\WorkspaceId
x -> (WorkspaceId
x, WorkspaceId -> Wallpaper
WallpaperFix (forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum WorkspaceId
x 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 <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  [WorkspaceId]
visws <- X [WorkspaceId]
getVisibleWorkspaces
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. a -> Maybe a
Just [WorkspaceId]
visws forall a. Eq a => a -> a -> Bool
/= Maybe [WorkspaceId]
oldws) 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just ProcessHandle
pid -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid

    ProcessHandle
handle <- [(Rectangle, WorkspaceId)] -> X ProcessHandle
applyWallpaper [(Rectangle, WorkspaceId)]
wspicpaths
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Maybe [WorkspaceId] -> Maybe ProcessHandle -> WCState
WCState (forall a. a -> Maybe a
Just [WorkspaceId]
visws) forall a b. (a -> b) -> a -> b
$ 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 <- forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0,forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list forall a. Num a => a -> a -> a
- Int
1)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a]
list 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 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 forall a b. (a -> b) -> a -> b
$ WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
dir
            let files' :: [WorkspaceId]
files' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceId
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)) [WorkspaceId]
files
            WorkspaceId
file <- forall a. [a] -> IO a
pickFrom [WorkspaceId]
files'
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ WallpaperConf -> WorkspaceId
wallpaperBaseDir WallpaperConf
conf WorkspaceId -> ShowS
</> WorkspaceId
dir WorkspaceId -> ShowS
</> WorkspaceId
file
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
getPicPath WallpaperConf
conf (WallpaperFix WorkspaceId
file) = do
  Bool
exist <- WorkspaceId -> IO Bool
doesFileExist WorkspaceId
path
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exist then forall a. a -> Maybe a
Just WorkspaceId
path else 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 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. (a -> b) -> [a] -> [b]
map 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
"")]] -> forall a. a -> Maybe a
Just (Int
w,Int
h)
    [[(Int, WorkspaceId)]]
_ -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO WorkspaceId
getHomeDirectory
  WindowSet
winset <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  let tags :: [WorkspaceId]
tags = forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
S.tag forall a b. (a -> b) -> a -> b
$ forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
S.workspaces WindowSet
winset
      dir' :: WorkspaceId
dir' = if 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 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
  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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall i l a. Workspace i l a -> i
S.tag 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
S.workspace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall i l a sid sd. Screen i l a sid sd -> sid
S.screen forall a b. (a -> b) -> a -> b
$ forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
S.current WindowSet
winset forall a. a -> [a] -> [a]
: 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  [(WorkspaceId, Maybe WorkspaceId)]
paths <- 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 = forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
S.current WindowSet
winset forall a. a -> [a] -> [a]
: 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 = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
x -> ((forall i l a. Workspace i l a -> i
S.tag 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
S.workspace) Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
x, 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 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
visws ]
  forall (m :: * -> *) a. Monad m => a -> m a
return [(Rectangle, WorkspaceId)]
foundpaths
  where getPicPaths :: IO [(WorkspaceId, Maybe WorkspaceId)]
getPicPaths = 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
                             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe WorkspaceId
p -> 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  let (Integer
vx,Integer
vy) = forall i l a sid.
StackSet i l a sid ScreenDetail -> (Integer, Integer)
getVScreenDim WindowSet
winset
  [WorkspaceId]
layers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> WorkspaceId
show Integer
vx forall a. [a] -> [a] -> [a]
++ WorkspaceId
"x" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> WorkspaceId
show Integer
vy 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 forall a. [a] -> [a] -> [a]
++ [WorkspaceId] -> WorkspaceId
unwords [WorkspaceId]
layers forall a. [a] -> [a] -> [a]
++ WorkspaceId
endpart
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall {a} {b}.
(Ord a, Ord b, Num a, Num b) =>
Rectangle -> (a, b) -> (a, b)
maxXY forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScreenDetail -> Rectangle
screenRect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sd
S.screenDetail) (Integer
0,Integer
0) 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]
S.screens
  where maxXY :: Rectangle -> (a, b) -> (a, b)
maxXY (Rectangle Position
x Position
y Dimension
w Dimension
h) (a
mx,b
my) = ( forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
xforall a. Num a => a -> a -> a
+Dimension
w) forall a. Ord a => a -> a -> a
`max` a
mx
                                            , forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
yforall a. Num a => a -> a -> a
+Dimension
h) 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_width Rectangle
rect) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Dimension
rect_height Rectangle
rect)
                                 pratio :: Double
pratio = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
px forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
py
                             in Double
wratio forall a. Ord a => a -> a -> Bool
> Double
1 Bool -> Bool -> Bool
&& Double
pratio forall a. Ord a => a -> a -> Bool
< Double
1 Bool -> Bool -> Bool
|| Double
wratio forall a. Ord a => a -> a -> Bool
< Double
1 Bool -> Bool -> Bool
&& Double
pratio 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
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Rectangle -> (Int, Int) -> Bool
needsRotation Rectangle
rect 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 = forall a. Show a => a -> WorkspaceId
show (Rectangle -> Dimension
rect_width Rectangle
rect) forall a. [a] -> [a] -> [a]
++ WorkspaceId
"x" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> WorkspaceId
show (Rectangle -> Dimension
rect_height Rectangle
rect) in
                     WorkspaceId
" \\( '"forall a. [a] -> [a] -> [a]
++WorkspaceId
pathforall a. [a] -> [a] -> [a]
++WorkspaceId
"' "forall a. [a] -> [a] -> [a]
++(if Bool
rotate then WorkspaceId
"-rotate 90 " else WorkspaceId
"")
                      forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -scale "forall a. [a] -> [a] -> [a]
++WorkspaceId
sizeforall a. [a] -> [a] -> [a]
++WorkspaceId
"^ -gravity center -extent "forall a. [a] -> [a] -> [a]
++WorkspaceId
sizeforall a. [a] -> [a] -> [a]
++WorkspaceId
" +gravity \\)"
                      forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -geometry +" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> WorkspaceId
show (Rectangle -> Position
rect_x Rectangle
rect) forall a. [a] -> [a] -> [a]
++ WorkspaceId
"+" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> WorkspaceId
show (Rectangle -> Position
rect_y Rectangle
rect) forall a. [a] -> [a] -> [a]
++ WorkspaceId
" -composite "