forked from arnihermann/osxmonad
/
Core.hs
190 lines (155 loc) · 5.53 KB
/
Core.hs
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}
module OSXMonad.Core where
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Exception (bracket)
import Control.Monad
import Data.Char
import Data.Maybe (fromMaybe)
import Data.List
import System.Exit
import System.IO
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import Foreign
import Foreign.C
import Graphics.X11 (Rectangle(..))
import qualified XMonad as XM
import qualified XMonad.Core as C
import qualified XMonad.Layout as L
import qualified XMonad.StackSet as S
import OSXMonad.Keys
import OSXMonad.Window
updateWindow :: Window -> IO ()
updateWindow window = do
with window setWindow
focusWindow :: Window -> IO ()
focusWindow window = do
with window setWindowFocused
rectangleWindow :: Rectangle -> Window -> Window
rectangleWindow (Rectangle x y w h) win =
win { pos = pos', size = size' }
where
pos' = CGPoint {
x = fromIntegral x,
y = fromIntegral y
}
size' = CGSize {
width = fromIntegral w,
height = fromIntegral h
}
eventModBits :: Event -> XM.ButtonMask
eventModBits event =
foldl ((. bits) . (+)) 0 [
(altKey, XM.mod1Mask),
(commandKey, XM.mod4Mask),
(controlKey, XM.controlMask),
(shiftKey, XM.shiftMask)
]
where bits (k, d) = if toBool (k event) then fromIntegral d else 0
getEvent :: IO Event
getEvent = do
collectEvent
peek globalEvent
getNamedWindows :: Ptr Windows -> IO [Window]
getNamedWindows context = do
count <- getWindows context
filledContext <- peek context
windowsPtrs <- peekArray count . elements $ filledContext
windows <- mapM (\winPtr -> peek winPtr) windowsPtrs
filterM (\win -> (peekCString . name $ win) >>= return . not . all isSpace) windows
tile' :: Ptr Windows -> XM.X ()
tile' context = do
event <- XM.io getEvent
ks <- XM.asks XM.keyActions
let modBits = eventModBits event
osxKey = osxKeyToX11 . fromIntegral . keyCode $ event
maybeAction = Map.lookup (modBits, osxKey) ks
fromMaybe (return ()) maybeAction
ws <- XM.gets C.windowset
namedWindows <- XM.io . getNamedWindows $ context
let wids = map (fromIntegral . wid) namedWindows
newStack = S.modify Nothing (S.filter (`elem` wids)) $ foldr S.insertUp ws $ wids
XM.modify (\s -> s { XM.windowset = newStack })
let rect = C.screenRect . S.screenDetail . S.current $ ws
(rectangles, _) <- C.runLayout (S.workspace . S.current $ ws) rect
let namedWindowsById = zip wids namedWindows
focusedWindow = S.peek newStack >>= flip lookup namedWindowsById
windows' = Maybe.catMaybes
$ map (\(i, r) ->
fmap (rectangleWindow r) (lookup i namedWindowsById)
) rectangles
maybe (return ()) (XM.io . focusWindow) focusedWindow
if null namedWindows
then return ()
else XM.io $ mapM_ updateWindow windows'
tile :: XM.X ()
tile = do
transitioning <- XM.io $ isSpaceTransitioning
if transitioning
then return ()
else do
context <- XM.io . new $ Windows nullPtr
tile' context
XM.io . freeWindows $ context
XM.io . free $ context
screenRectangle :: IO Rectangle
screenRectangle = do
screenPosPtr <- new (CGPoint 0 0)
screenSizePtr <- new (CGSize 0 0)
getFrame screenPosPtr screenSizePtr
screenSize <- peek screenSizePtr
screenPos <- peek screenPosPtr
free screenSizePtr
free screenPosPtr
return $ Rectangle {
rect_x = round . x $ screenPos,
rect_y = round . y $ screenPos,
rect_width = round . width $ screenSize,
rect_height = round . height $ screenSize
}
osxWindows :: (XM.WindowSet -> XM.WindowSet) -> XM.X ()
osxWindows f = do
XM.XState { C.windowset = old } <- XM.get
let ws = f old
XM.modify (\s -> s { C.windowset = ws })
osxSendMessage :: C.Message a => a -> XM.X ()
osxSendMessage a = do
w <- S.workspace . S.current <$> XM.gets C.windowset
ml' <- C.handleMessage (S.layout w) (C.SomeMessage a) `C.catchX` return Nothing
C.whenJust ml' $ \l' ->
osxWindows $ \ws -> ws { S.current = (S.current ws)
{ S.workspace = (S.workspace $ S.current ws)
{ S.layout = l' }}}
osxmonad :: (C.LayoutClass l XM.Window, Read (l XM.Window)) => XM.XConfig l -> IO ()
osxmonad initxmc = do
setupEventCallback
rect <- screenRectangle
let display = error "display"
xmc = initxmc { C.layoutHook = C.Layout $ C.layoutHook initxmc }
theRoot = 0
normalBorder = 0
focusedBorder = 0
buttonActions = Map.empty
mouseFocused = False
mousePosition = Nothing
layout = C.layoutHook xmc
windowset = S.new layout (C.workspaces xmc) $ [C.SD rect] -- TODO: All screen sizes
mapped = Set.empty
waitingUnmap = Map.empty
dragging = Nothing
numberlockMask = 0
extensibleState = Map.empty
conf = C.XConf display xmc theRoot normalBorder focusedBorder (XM.keys xmc xmc) buttonActions mouseFocused mousePosition
state = C.XState windowset mapped waitingUnmap dragging numberlockMask extensibleState
hasAPI <- axAPIEnabled
if not hasAPI
then do
hPutStrLn stderr "You need to enable access for Accessible Devices in Universal Access"
exitWith $ ExitFailure 1
else do
XM.runX conf state . forever $ do
tile
XM.io . threadDelay $ 1000 * 500
return ()