diff options
Diffstat (limited to 'XMonad/Hooks/WallpaperSetter.hs')
| -rw-r--r-- | XMonad/Hooks/WallpaperSetter.hs | 222 |
1 files changed, 222 insertions, 0 deletions
diff --git a/XMonad/Hooks/WallpaperSetter.hs b/XMonad/Hooks/WallpaperSetter.hs new file mode 100644 index 0000000..feb409b --- /dev/null +++ b/XMonad/Hooks/WallpaperSetter.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------- +-- | +-- Module : XMonad.Hooks.WallpaperSetter +-- 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 +, defWPNames + -- *TODO + -- $todo +) where +import XMonad +import qualified XMonad.StackSet as S +import qualified XMonad.Util.ExtensibleState as XS + +import System.IO +import System.Process +import System.Exit +import System.Directory (getHomeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents) +import System.FilePath ((</>)) +import System.Random (getStdRandom, randomR) + +import qualified Data.Map as M +import qualified Data.Text as T +import Data.List (intersperse, sortBy) +import Data.Char (isAlphaNum) +import Data.Ord (comparing) + +import Control.Monad (when, unless, join) +import Data.Maybe (isNothing, fromJust, fromMaybe) +import Data.Monoid + +-- $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 $ defaultConfig { +-- > 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 [(String,String)] (Maybe ProcessHandle) deriving Typeable +instance ExtensionClass WCState where + initialValue = WCState [] Nothing + +-- | Represents a wallpaper +data Wallpaper = WallpaperFix FilePath -- ^ Single, fixed wallpaper + | WallpaperDir FilePath -- ^ Random wallpaper from this subdirectory + deriving (Eq, Show, Read) + +newtype WallpaperList = WallpaperList [(WorkspaceId, Wallpaper)] + deriving (Show,Read) + +instance Monoid WallpaperList where + mempty = WallpaperList [] + mappend (WallpaperList w1) (WallpaperList w2) = + WallpaperList $ M.toList $ (M.fromList w2) `M.union` (M.fromList w1) + +-- | Complete wallpaper configuration passed to the hook +data WallpaperConf = WallpaperConf { + wallpaperBaseDir :: FilePath -- ^ Where the wallpapers reside (if empty, will look in \~\/.wallpapers/) + , wallpapers :: WallpaperList -- ^ List of the wallpaper associations for workspaces + } deriving (Show, Read) + +-- | default configuration. looks in \~\/.wallpapers/ for WORKSPACEID.jpg +defWallpaperConf = WallpaperConf "" $ WallpaperList [] + +-- |returns the default association list (maps name to name.jpg, non-alphanumeric characters are omitted) +defWPNames :: [WorkspaceId] -> WallpaperList +defWPNames xs = WallpaperList $ map (\x -> (x,WallpaperFix (filter isAlphaNum x++".jpg"))) xs + +-- | Add this to your log hook with the workspace configuration as argument. +wallpaperSetter :: WallpaperConf -> X () +wallpaperSetter wpconf = do + WCState st h <- XS.get + let oldws = fromMaybe "" $ M.lookup "oldws" $ M.fromList st + visws <- getVisibleWorkspaces + when (show visws /= oldws) $ do + -- debug $ show visws + + wpconf' <- completeWPConf wpconf + wspicpaths <- getPicPathsAndWSRects wpconf' + + -- terminate old call if any to prevent unnecessary CPU overload when switching WS too fast + case h of + Nothing -> return () + Just pid -> liftIO $ terminateProcess pid + + handle <- applyWallpaper wspicpaths + XS.put $ WCState [("oldws", show visws)] $ Just handle + +-- Helper functions +------------------- + +-- | Picks a random element from a list +pickFrom :: [a] -> IO a +pickFrom list = do + i <- getStdRandom $ randomR (0,length list - 1) + return $ list !! 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 conf (WallpaperDir dir) = do + direxists <- doesDirectoryExist $ wallpaperBaseDir conf </> dir + if direxists + then do files <- getDirectoryContents $ wallpaperBaseDir conf </> dir + let files' = filter ((/='.').head) files + file <- pickFrom files' + return $ Just $ wallpaperBaseDir conf </> dir </> file + else return Nothing +getPicPath conf (WallpaperFix file) = do + exist <- doesFileExist path + return $ if exist then Just path else Nothing + where path = wallpaperBaseDir conf </> 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 picpath = do + (_, Just outh,_,pid) <- createProcess $ (proc "identify" [picpath]) { std_out = CreatePipe } + output <- hGetContents outh + return $ if (length $ words output) < 3 then Nothing else splitRes (words output !! 2) + +-- |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 dir (WallpaperList ws)) = do + home <- liftIO getHomeDirectory + winset <- gets windowset + let tags = map S.tag $ S.workspaces winset + dir' = if null dir then home </> ".wallpapers" else dir + ws' = if null ws then defWPNames tags else WallpaperList ws + return (WallpaperConf dir' ws') + +getVisibleWorkspaces :: X [WorkspaceId] +getVisibleWorkspaces = do + winset <- gets windowset + return $ map (S.tag . S.workspace) . sortBy (comparing S.screen) $ S.current winset : S.visible winset + +getPicPathsAndWSRects :: WallpaperConf -> X [(Rectangle, FilePath)] +getPicPathsAndWSRects wpconf = do + winset <- gets windowset + paths <- liftIO $ getPicPaths wpconf + visws <- getVisibleWorkspaces + let visscr = S.current winset : S.visible winset + visrects = M.fromList $ map (\x -> ((S.tag . S.workspace) x, S.screenDetail x)) visscr + hasPicAndIsVisible (n, mp) = n `elem` visws && (not$isNothing mp) + getRect tag = screenRect $ fromJust $ M.lookup tag visrects + foundpaths = map (\(n,Just p)->(getRect n,p)) $ filter hasPicAndIsVisible paths + return foundpaths + where getPicPaths wpconf = mapM (\(x,y) -> getPicPath wpconf y + >>= \p -> return (x,p)) wl + WallpaperList wl = wallpapers wpconf + +-- | Gets a list of geometry rectangles and filenames, builds and sets wallpaper +applyWallpaper :: [(Rectangle, FilePath)] -> X ProcessHandle +applyWallpaper parts = do + winset <- gets windowset + let (vx,vy) = getVScreenDim winset + layers <- liftIO $ mapM layerCommand parts + let basepart ="convert -size "++show vx++"x"++show vy++" xc:black " + endpart =" jpg:- | feh --no-xinerama --bg-tile --no-fehbg -" + cmd = basepart ++ (concat $ intersperse " " layers) ++ endpart + liftIO $ runCommand cmd + where + getVScreenDim = foldr maxXY (0,0) . map (screenRect . S.screenDetail) . S.screens + where maxXY (Rectangle x y w h) (mx,my) = ( fromIntegral ((fromIntegral x)+w) `max` mx + , fromIntegral ((fromIntegral y)+h) `max` my ) + needsRotation (px,py) rect = let wratio = (fromIntegral $ rect_width rect) / (fromIntegral $ rect_height rect) + pratio = fromIntegral px / fromIntegral py + in wratio > 1 && pratio < 1 || wratio < 1 && pratio > 1 + layerCommand (rect, path) = do + res <- getPicRes path + if isNothing res then return "" + else do let rotate = needsRotation (fromJust res) rect + return $ " \\( '"++path++"' "++(if rotate then "-rotate 90 " else "") + ++ " -scale "++(show$rect_width rect)++"x"++(show$rect_height rect)++"! \\)" + ++ " -geometry +"++(show$rect_x rect)++"+"++(show$rect_y rect)++" -composite " + + +-- | internal. output string to /tmp/DEBUG +debug str = liftIO $ runCommand $ "echo \"" ++ str ++ "\" >> /tmp/DEBUG" + +-- |split a string at a delimeter +split delim str = map T.unpack $ T.splitOn (T.pack delim) (T.pack str) +-- |XxY -> Maybe (X,Y) +splitRes str = ret + where toks = map (\x -> read x :: Int) $ split "x" str + ret = if length toks < 2 then Nothing else Just (toks!!0,toks!!1) + |