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
|
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
ScopedTypeVariables, BangPatterns #-}
module Internal.LayoutDraw where
import System.Process
import Text.Printf
import Control.Arrow
import Control.Exception
import Control.Monad
import Graphics.Rendering.Cairo
import Graphics.Rendering.Cairo.Internal (Render(runRender))
import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
import System.FilePath
import XMonad
import XMonad.StackSet as S
import Data.Maybe
import System.Directory
import Internal.Layout
import Internal.Hash
showLayout :: X (Maybe String)
showLayout = do
winset <- gets windowset
let layout = S.layout . S.workspace . S.current $ winset
xpm <- drawPng layout
return $ Just $ printf "<icon=%s/>" xpm
iconSize :: (Num a) => (a, a)
iconSize = (64, 32)
drawPng :: (LayoutClass layout Window) => layout Window -> X String
drawPng l = do
dir <- getXMonadDir
let sixWindows = [1..(4 :: Window)]
let stack = differentiate sixWindows
(rects, _) <-
runLayout
(Workspace "0" l stack)
(Rectangle 0 0 (fst iconSize * 30) (snd iconSize * 30))
return ()
let descr = description l
let pngCacheDir = dir </> "icons" </> "cache"
liftIO $ createDirectoryIfMissing True pngCacheDir
let testf = dir </> "text.txt"
let filepathPng = pngCacheDir </> (quickHash descr ++ ".png")
let filepathXpm = pngCacheDir </> (quickHash descr ++ ".xpm")
let colors = [
-- (1.0, 1.0, 1.0),
-- (0.9, 0.9, 1.0),
-- (0.8, 0.8, 1.0),
-- (0.7, 0.7, 1.0),
(0.8, 0.6, 0.6),
(0.8, 0.5, 0.5),
(0.8, 0.4, 0.4),
(0.8, 0.3, 0.3),
(0.8, 0.2, 0.2),
(0.8, 0.1, 0.1),
(0.8, 0.0, 0.0)
]
exists <- liftIO $ doesFileExist filepathXpm
when (not exists) $
liftIO $ do
withImageSurface FormatARGB32 64 32 $ \surface -> do
renderWith surface $ do
setLineCap LineCapButt
setLineJoin LineJoinMiter
forM_ (reverse $ zip (map (second extraPad) rects) colors) $
\((wind, Rectangle x y w h), (r, g, b)) -> do
setSourceRGBA r g b 1
rectangle
(fromIntegral $ floor (fromIntegral x / 30.0))
(fromIntegral $ floor (fromIntegral y / 30.0))
(fromIntegral $ floor (fromIntegral w / 30.0))
(fromIntegral $ floor (fromIntegral h / 30.0))
fill
surfaceWriteToPNG surface filepathPng
(!_) <- readProcessWithExitCode
"/usr/bin/convert"
[filepathPng, filepathXpm]
""
return ()
return filepathXpm
where
extraPad (Rectangle x y w h) =
Rectangle (x + 100) (y + 100) (w - 100) (h - 100)
-- padR (Rectangle x y w h) =
-- Rectangle x y (max 1 $ w - 120) (max 1 $ h - 120)
newtype InterceptLayout l a =
InterceptLayout {
unIntercept :: (l a)
} deriving (Show, Read)
instance (LayoutClass l Window) => LayoutClass (InterceptLayout l) Window where
runLayout (Workspace t l s) rect = do
(rects, mr) <- runLayout (Workspace t (unIntercept l) s) rect
return (rects, fmap InterceptLayout mr)
handleMessage this mesg = do
ret <- handleMessage (unIntercept this) mesg
-- mapM_ drawThing ret
return (InterceptLayout <$> ret)
description = ("Intercepted "++) . description . unIntercept
|
