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
|
{-# 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 Control.Concurrent (threadDelay)
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
out <- 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
|
