    {-# 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.Directory (getHomeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents)
    import System.FilePath ((</>))
    import System.Random (randomRIO)

    import qualified Data.Map as M
    import Data.List (intersperse, sortBy)
    import Data.Char (isAlphaNum)
    import Data.Ord (comparing)

    import Control.Monad
    import Control.Applicative
    import Data.Maybe
    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 (Maybe [WorkspaceId]) (Maybe ProcessHandle) deriving Typeable
    instance ExtensionClass WCState where
      initialValue = WCState Nothing 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
    defWallpaperConf = WallpaperConf "" $ WallpaperList []

    instance Default WallpaperConf where
        def = defWallpaperConf

    -- |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 oldws h <- XS.get
      visws <- getVisibleWorkspaces
      when (Just visws /= oldws) $ do

        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 (Just visws) $ Just handle

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

    -- | Picks a random element from a list
    pickFrom :: [a] -> IO a
    pickFrom list = do
      i <- randomRIO (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" ["-format", "%w %h", picpath]) { std_out = CreatePipe }
      output <- hGetContents outh
      return $ case map reads (words output) of
        -- mapM Text.Read.readMaybe is better but only in ghc>=7.6
        [[(w,"")],[(h,"")]] -> Just (w,h)
        _ -> 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 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
      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 && (isJust mp)
          getRect tag = screenRect $ fromJust $ M.lookup tag visrects
          foundpaths = map (\(n,Just p)->(getRect n,p)) $ filter hasPicAndIsVisible paths
      return foundpaths
      where getPicPaths = 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

    getVScreenDim :: S.StackSet i l a sid ScreenDetail -> (Integer, Integer)
    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 :: Rectangle -> (Int,Int) -> Bool
    needsRotation rect (px,py) = let wratio, pratio :: Double
                                     wratio = (fromIntegral $ rect_width rect) / (fromIntegral $ rect_height rect)
                                     pratio = fromIntegral px / fromIntegral py
                                 in wratio > 1 && pratio < 1 || wratio < 1 && pratio > 1

    layerCommand :: (Rectangle, FilePath) -> IO String
    layerCommand (rect, path) = do
      res <- getPicRes path
      return $ case needsRotation rect <$> res of
        Nothing -> ""
        Just rotate ->
                         " \\( '"++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 "