1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
ScopedTypeVariables, BangPatterns #-}
module Internal.LayoutDraw where
import System.IO
import Control.Monad.Writer
import XMonad.Layout.Spacing
import System.Process
import Text.Printf
import Control.Arrow
import Control.Exception
import Control.Monad
import Control.Concurrent (threadDelay)
import System.FilePath
import XMonad
import XMonad.StackSet as S
import Data.Maybe
import Data.Foldable
import System.Directory
import Internal.Layout
import Internal.Hash
showLayout :: X (Bool, String, Maybe String)
showLayout = do
winset <- gets windowset
let layout = S.layout . S.workspace . S.current $ winset
layout' <- handleMessage layout (
SomeMessage $ ModifyWindowBorder (
const (Border 0 0 0 0)))
let layout'' = layout'
(cached, xpm) <-
case layout'' of
Just l -> drawXpmIO l
Nothing -> drawXpmIO layout
return $ (cached, description layout, Just $ printf "<icon=%s/>" xpm)
pointInRect :: (Dimension, Dimension) -> Rectangle -> Bool
pointInRect (x, y) (Rectangle x' y' w h) =
x <= (fi x' + fi w) && x >= fi x' && y <= (fi y' + fi h) && y >= fi y'
where
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
sf :: (Integral a) => a
sf = 1024
drawXpmIO :: (LayoutClass layout Window) => layout Window -> X (Bool, String)
drawXpmIO l = do
dir <- getXMonadDir
let shrinkAmt = 4
let (w, h) = (56 + shrinkAmt, 28 + shrinkAmt)
let descr = description l
let iconCacheDir = dir </> "icons" </> "cache"
let iconPath = iconCacheDir </> (quickHash descr ++ ".xpm")
let colors = [
"#cc9a9a",
"#cc9999",
"#cc8080",
"#cc6666",
"#cc4c4c",
"#cc3232",
"#cc1818"
]
(rects', _) <-
runLayout
(Workspace "0" l (differentiate [1 .. 6]))
(Rectangle 0 0 (w * sf) (h * sf))
let rects = flip map rects' $ \(_, (Rectangle x y w h)) ->
Rectangle (x `div` sf) (y `div` sf) (w `div` sf) (h `div` sf)
liftIO $ do
exists <- doesFileExist iconPath
createDirectoryIfMissing True iconCacheDir
when (not exists) $ do
let xpmText = drawXpm (w, h) (zip (cycle colors) rects) 4
writeFile iconPath xpmText
return (exists, iconPath)
drawXpm :: (Dimension, Dimension) -> [(String, Rectangle)] -> Dimension -> String
drawXpm (w, h) rects' shrinkAmt = execWriter $ do
tell "/* XPM */\n"
tell "static char *out[] = {\n"
forM_ rects' $ \(_, rect) -> do
tell $ "/* " ++ show rect ++ " */\n"
tell $ "/* --------------------------- */\n"
forM_ rects $ \(_, rect) -> do
tell $ "/* " ++ show rect ++ " */\n"
tell $ printf "\"%d %d %d 1 \",\n" (w - shrinkAmt) (h - shrinkAmt) (length rects + 1)
let zipRects = (zip ['A' .. 'Z'] rects)
forM_ zipRects $ \(char, (color, _)) -> do
tell $ printf "\"%c c %s\",\n" char color
tell "\"% c None\"a,\n"
forM_ [0 .. h - 1 - shrinkAmt] $ \y -> do
tell "\""
forM_ [0 .. w - 1 - shrinkAmt] $ \x ->
(case find (matches x y) zipRects of
Nothing -> tell "%"
Just (chr, _) -> tell [chr])
tell "\""
when (y /= h - 1 - shrinkAmt) (tell ",")
tell "\n"
tell "};"
where
matches x y (_, (_, r)) = pointInRect (x, y) r
rects = map (second (shrink shrinkAmt)) rects'
guard a b = if a <= shrinkAmt then 1 else b
shrink amt (Rectangle x y w h) =
Rectangle
x
y
(guard w $ w - fromIntegral amt)
(guard h $ h - fromIntegral amt)
|
