├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── cbits ├── ir.c ├── ir.h ├── quartz.h ├── quartz.m └── quartz_stubs.h ├── iridium-quartz.ipkg └── src ├── IR.idr ├── IR ├── Event.idr ├── Layout.idr ├── Lens.idr ├── Reader.idr └── StackSet.idr ├── MakefileC └── Quartz.idr /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | iridium 4 | *.o 5 | *.ibc 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Brian McKenna 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | IDRIS := idris 2 | 3 | quartz: 4 | ${IDRIS} --build iridium-quartz.ipkg 5 | ${IDRIS} -i src -p effects -o iridium Quartz 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A version of [xmonad](http://xmonad.org/) which abstracts away X11 and 2 | is written in and configured by Idris, rather than Haskell. 3 | -------------------------------------------------------------------------------- /cbits/ir.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "ir.h" 3 | 4 | void irFrameFree(IRFrame *frame) { 5 | free(frame); 6 | } 7 | 8 | double irFrameX(IRFrame *frame) { 9 | return frame->x; 10 | } 11 | 12 | double irFrameY(IRFrame *frame) { 13 | return frame->y; 14 | } 15 | 16 | double irFrameW(IRFrame *frame) { 17 | return frame->w; 18 | } 19 | 20 | double irFrameH(IRFrame *frame) { 21 | return frame->h; 22 | } 23 | 24 | void irEventFree(IREvent *event) { 25 | free(event); 26 | } 27 | 28 | int irEventType(IREvent *event) { 29 | return event->type; 30 | } 31 | 32 | int irEventKeyCode(IREvent *event) { 33 | return event->keyCode; 34 | } 35 | 36 | int irEventKeyAlternate(IREvent *event) { 37 | return event->modifiers & IRKeyModifierAlternate; 38 | } 39 | 40 | int irEventKeyCommand(IREvent *event) { 41 | return event->modifiers & IRKeyModifierCommand; 42 | } 43 | 44 | int irEventKeyControl(IREvent *event) { 45 | return event->modifiers & IRKeyModifierControl; 46 | } 47 | 48 | int irEventKeyShift(IREvent *event) { 49 | return event->modifiers & IRKeyModifierShift; 50 | } 51 | -------------------------------------------------------------------------------- /cbits/ir.h: -------------------------------------------------------------------------------- 1 | #ifndef __IR_H 2 | #define __IR_H 3 | 4 | typedef struct { 5 | double x; 6 | double y; 7 | double w; 8 | double h; 9 | } IRFrame; 10 | 11 | typedef enum { 12 | IRKeyDownEventType, 13 | IRRefreshEventType, 14 | IRIgnoredEventType 15 | } IREventType; 16 | 17 | typedef enum { 18 | IRKeyModifierAlternate = 1 << 0, 19 | IRKeyModifierCommand = 1 << 1, 20 | IRKeyModifierControl = 1 << 2, 21 | IRKeyModifierShift = 1 << 3 22 | } IRKeyModifier; 23 | 24 | typedef struct { 25 | IREventType type; 26 | unsigned short keyCode; 27 | IRKeyModifier modifiers; 28 | } IREvent; 29 | 30 | void irFrameFree(IRFrame *frame); 31 | double irFrameX(IRFrame *frame); 32 | double irFrameY(IRFrame *frame); 33 | double irFrameW(IRFrame *frame); 34 | double irFrameH(IRFrame *frame); 35 | 36 | void irEventFree(IREvent *event); 37 | int irEventType(IREvent *event); 38 | int irEventKeyCode(IREvent *event); 39 | int irEventKeyAlternate(IREvent *event); 40 | int irEventKeyCommand(IREvent *event); 41 | int irEventKeyControl(IREvent *event); 42 | int irEventKeyShift(IREvent *event); 43 | 44 | #endif /* __IR_H */ 45 | -------------------------------------------------------------------------------- /cbits/quartz.h: -------------------------------------------------------------------------------- 1 | typedef struct QuartzWindows { 2 | int length; 3 | int *wids; 4 | int focused; 5 | } QuartzWindows; 6 | 7 | typedef struct QuartzScreens { 8 | int length; 9 | IRFrame *frames; 10 | } QuartzScreens; 11 | 12 | typedef enum QuartzEventType { 13 | QuartzApplicationDeactivateEvent 14 | } QuartzEventType; 15 | 16 | int quartzInit(); 17 | int quartzSpacesCount(); 18 | void *quartzEvent(); 19 | void *quartzScreens(); 20 | void quartzScreensFree(QuartzScreens *screens); 21 | int quartzScreensLength(QuartzScreens *screens); 22 | void *quartzScreensFrame(QuartzScreens *screens, int index); 23 | void quartzGrabKey(int keyCode, int alternative, int command, int control, int shift); 24 | 25 | void quartzWindowsFree(QuartzWindows *windows); 26 | void *quartzWindows(); 27 | int quartzWindowId(QuartzWindows *windows, int index); 28 | int quartzWindowsLength(QuartzWindows *windows); 29 | int quartzWindowsFocusedId(QuartzWindows *windows); 30 | 31 | void quartzWindowSetRect(int wid, double x, double y, double w, double h); 32 | void quartzWindowSetFocus(int wid); 33 | -------------------------------------------------------------------------------- /cbits/quartz.m: -------------------------------------------------------------------------------- 1 | #include 2 | #include "ir.h" 3 | #include "quartz.h" 4 | #include "quartz_stubs.h" 5 | 6 | @interface QuartzGrabbedKey : NSObject 7 | 8 | @property unsigned short keyCode; 9 | @property NSUInteger modifierFlags; 10 | 11 | - (id)initWithKeyCode:(unsigned short)aKeyCode modifierFlags:(NSUInteger)aModifierFlags; 12 | 13 | @end 14 | 15 | @implementation QuartzGrabbedKey 16 | 17 | - (id)initWithKeyCode:(unsigned short)aKeyCode modifierFlags:(NSUInteger)aModifierFlags { 18 | if (self = [super init]) { 19 | self.keyCode = aKeyCode; 20 | self.modifierFlags = aModifierFlags; 21 | } 22 | return self; 23 | } 24 | 25 | @end 26 | 27 | CFMachPortRef quartzEventTap; 28 | NSMutableSet *quartzGrabbedKeys; 29 | 30 | void quartzPostDeactivateEvent() { 31 | [NSApp postEvent:[NSEvent otherEventWithType:NSApplicationDefined location:NSMakePoint(0,0) modifierFlags:0 timestamp:0 windowNumber:0 context:nil subtype:QuartzApplicationDeactivateEvent data1:0 data2:0] atStart:NO]; 32 | } 33 | 34 | void quartzApplicationDeactivateCallback(NSNotification *notification) { 35 | quartzPostDeactivateEvent(); 36 | } 37 | 38 | CGEventRef quartzEventCallback(CGEventTapProxy proxy, CGEventType type, CGEventRef event, void *ref) { 39 | switch (type) { 40 | case kCGEventKeyDown: 41 | { 42 | NSEvent *ee = [NSEvent eventWithCGEvent:event]; 43 | for (QuartzGrabbedKey *grabbedKey in quartzGrabbedKeys) { 44 | unsigned long modifierFlags = [ee modifierFlags]; 45 | if (grabbedKey.keyCode == [ee keyCode] && (grabbedKey.modifierFlags & modifierFlags) == grabbedKey.modifierFlags) { 46 | [NSApp postEvent:ee atStart:NO]; 47 | return NULL; 48 | } 49 | } 50 | } 51 | break; 52 | case kCGEventTapDisabledByTimeout: 53 | case kCGEventTapDisabledByUserInput: 54 | CGEventTapEnable(quartzEventTap, YES); 55 | return NULL; 56 | default: 57 | [NSApp postEvent:[NSEvent eventWithCGEvent:event] atStart:NO]; 58 | } 59 | return event; 60 | } 61 | 62 | void quartzObserverCallback(AXObserverRef observer, AXUIElementRef element, CFStringRef notificationName, void *data) { 63 | quartzPostDeactivateEvent(); 64 | } 65 | 66 | void quartzAttachEvents() { 67 | CGEventMask eventMask = CGEventMaskBit(kCGEventKeyDown); 68 | quartzEventTap = CGEventTapCreate(kCGHIDEventTap, kCGHeadInsertEventTap, kCGEventTapOptionDefault, eventMask, quartzEventCallback, NULL); 69 | CFRunLoopSourceRef runLoopSource = CFMachPortCreateRunLoopSource(kCFAllocatorDefault, quartzEventTap, 0); 70 | CFRunLoopAddSource(CFRunLoopGetCurrent(), runLoopSource, kCFRunLoopDefaultMode); 71 | CGEventTapEnable(quartzEventTap, YES); 72 | CFRelease(runLoopSource); 73 | // CFRelease(quartzEventTap); 74 | 75 | for (NSRunningApplication *runningApp in [[NSWorkspace sharedWorkspace] runningApplications]) { 76 | AXUIElementRef axElementRef = AXUIElementCreateApplication(runningApp.processIdentifier); 77 | 78 | AXObserverRef axObserver; 79 | AXObserverCreate(runningApp.processIdentifier, quartzObserverCallback, &axObserver); 80 | 81 | AXObserverAddNotification(axObserver, axElementRef, kAXWindowMiniaturizedNotification, NULL); 82 | AXObserverAddNotification(axObserver, axElementRef, kAXWindowMovedNotification, NULL); 83 | AXObserverAddNotification(axObserver, axElementRef, kAXWindowResizedNotification, NULL); 84 | // AXObserverAddNotification(axObserver, axElementRef, kAXFocusedWindowChangedNotification, NULL); 85 | 86 | CFRelease(axElementRef); 87 | 88 | CFRunLoopAddSource(CFRunLoopGetCurrent(), AXObserverGetRunLoopSource(axObserver), kCFRunLoopDefaultMode); 89 | } 90 | 91 | NSNotificationCenter *center = [[NSWorkspace sharedWorkspace] notificationCenter]; 92 | [center addObserverForName:NSWorkspaceDidDeactivateApplicationNotification object:nil queue:nil usingBlock:^(NSNotification *notiication) { 93 | quartzApplicationDeactivateCallback(notiication); 94 | }]; 95 | } 96 | 97 | int quartzInit() { 98 | [NSApplication sharedApplication]; 99 | [NSApp finishLaunching]; 100 | Boolean success = AXIsProcessTrusted(); 101 | 102 | quartzGrabbedKeys = [NSMutableSet setWithCapacity:0]; 103 | 104 | // [NSScreen screensHaveSeparateSpaces]; 105 | 106 | if (success) { 107 | quartzAttachEvents(); 108 | } 109 | 110 | return success; 111 | } 112 | 113 | int quartzSpacesCount() { 114 | CFArrayRef spaces = CGSCopySpaces(CGSDefaultConnection, kCGSSpaceAll); 115 | int count = CFArrayGetCount(spaces) - 1; 116 | CFRelease(spaces); 117 | return count; 118 | } 119 | 120 | int quartzCurrentSpaceId() { 121 | CFArrayRef currentSpace = CGSCopySpaces(CGSDefaultConnection, kCGSSpaceCurrent); 122 | uint64_t currentSpaceId = [(id)CFArrayGetValueAtIndex(currentSpace, 0) intValue]; 123 | CFRelease(currentSpace); 124 | return currentSpaceId; 125 | } 126 | 127 | void *quartzFindWindow(int wid) { 128 | for (NSRunningApplication *runningApp in [[NSWorkspace sharedWorkspace] runningApplications]) { 129 | AXUIElementRef axElementRef = AXUIElementCreateApplication(runningApp.processIdentifier); 130 | CFArrayRef windowsArrayRef; 131 | AXUIElementCopyAttributeValues(axElementRef, kAXWindowsAttribute, 0, 100, &windowsArrayRef); 132 | 133 | NSArray *windowRefs = CFBridgingRelease(windowsArrayRef); 134 | for (NSUInteger index = 0; index < windowRefs.count; ++index) { 135 | AXUIElementRef windowRef = (__bridge AXUIElementRef)windowRefs[index]; 136 | 137 | CGWindowID windowRefId; 138 | _AXUIElementGetWindow(windowRef, &windowRefId); 139 | 140 | // TODO: Should we ignore Dash windows? 141 | 142 | if (wid == windowRefId) { 143 | CFRelease(axElementRef); 144 | return (void *)windowRef; 145 | } 146 | } 147 | 148 | CFRelease(axElementRef); 149 | } 150 | 151 | return NULL; 152 | } 153 | 154 | void quartzWindowSetRect(int wid, double x, double y, double w, double h) { 155 | AXUIElementRef window = quartzFindWindow(wid); 156 | 157 | if (window == NULL) 158 | return; 159 | 160 | CGPoint point = CGPointMake(x, y); 161 | AXValueRef pointRef = AXValueCreate(kAXValueCGPointType, &point); 162 | AXUIElementSetAttributeValue(window, kAXPositionAttribute, pointRef); 163 | CFRelease(pointRef); 164 | 165 | CGSize size = CGSizeMake(w, h); 166 | AXValueRef sizeRef = AXValueCreate(kAXValueCGSizeType, &size); 167 | AXUIElementSetAttributeValue(window, kAXSizeAttribute, sizeRef); 168 | CFRelease(sizeRef); 169 | 170 | CFRelease(window); 171 | } 172 | 173 | void quartzWindowSetFocus(int wid) { 174 | AXUIElementRef window = quartzFindWindow(wid); 175 | 176 | if (window == NULL) 177 | return; 178 | 179 | AXUIElementSetAttributeValue(window, kAXMainAttribute, kCFBooleanTrue); 180 | 181 | CFTypeRef applicationRef; 182 | AXUIElementCopyAttributeValue(window, kAXParentAttribute, &applicationRef); 183 | AXUIElementSetAttributeValue(applicationRef, kAXFrontmostAttribute, kCFBooleanTrue); 184 | CFRelease(applicationRef); 185 | 186 | CFRelease(window); 187 | } 188 | 189 | void quartzWindowFree(void *window) { 190 | CFRelease(window); 191 | } 192 | 193 | #define QUARTZ_WINDOWS_LENGTH 100 194 | 195 | void *quartzWindows() { 196 | QuartzWindows *windows = malloc(sizeof(QuartzWindows)); 197 | windows->length = 0; 198 | windows->wids = malloc(sizeof(int) * QUARTZ_WINDOWS_LENGTH); 199 | 200 | for (NSRunningApplication *runningApp in [[NSWorkspace sharedWorkspace] runningApplications]) { 201 | AXUIElementRef axElementRef = AXUIElementCreateApplication(runningApp.processIdentifier); 202 | CFArrayRef windowsArrayRef; 203 | AXUIElementCopyAttributeValues(axElementRef, kAXWindowsAttribute, 0, QUARTZ_WINDOWS_LENGTH, &windowsArrayRef); 204 | 205 | CFBooleanRef frontMostRef; 206 | AXUIElementCopyAttributeValue(axElementRef, kAXFrontmostAttribute, (const void **)&frontMostRef); 207 | 208 | NSArray *windowRefs = CFBridgingRelease(windowsArrayRef); 209 | for (NSUInteger index = 0; index < windowRefs.count; ++index) { 210 | AXUIElementRef windowRef = (__bridge AXUIElementRef)windowRefs[index]; 211 | 212 | CFTypeRef subroleRef; 213 | AXUIElementCopyAttributeValue(windowRef, kAXSubroleAttribute, &subroleRef); 214 | NSString *subrole = CFBridgingRelease(subroleRef); 215 | 216 | CGWindowID wid; 217 | _AXUIElementGetWindow(windowRef, &wid); 218 | 219 | CFBooleanRef mainRef; 220 | AXUIElementCopyAttributeValue(windowRef, kAXMainAttribute, (const void **)&mainRef); 221 | 222 | if (CFBooleanGetValue(frontMostRef) && CFBooleanGetValue(mainRef)) { 223 | windows->focused = wid; 224 | } 225 | 226 | if ([subrole isEqualToString:(__bridge NSString *)kAXStandardWindowSubrole]) { 227 | if (windows->length < QUARTZ_WINDOWS_LENGTH) { 228 | windows->wids[windows->length] = wid; 229 | windows->length++; 230 | } 231 | } 232 | } 233 | 234 | CFRelease(axElementRef); 235 | } 236 | 237 | return windows; 238 | } 239 | 240 | void quartzWindowsFree(QuartzWindows *windows) { 241 | free(windows->wids); 242 | free(windows); 243 | } 244 | 245 | int quartzWindowId(QuartzWindows *windows, int index) { 246 | return windows->wids[index]; 247 | } 248 | 249 | int quartzWindowsLength(QuartzWindows *windows) { 250 | return windows->length; 251 | } 252 | 253 | int quartzWindowsFocusedId(QuartzWindows *windows) { 254 | return windows->focused; 255 | } 256 | 257 | void *quartzScreens() { 258 | NSArray *frames = [NSScreen screens]; 259 | 260 | QuartzScreens *screens = malloc(sizeof(QuartzScreens)); 261 | 262 | NSUInteger count = [frames count]; 263 | screens->length = count; 264 | screens->frames = malloc(sizeof(IRFrame) * count); 265 | 266 | unsigned int i = 0; 267 | for (NSScreen *screen in frames) { 268 | NSRect frame = [screen frame]; 269 | NSRect visibleFrame = [screen visibleFrame]; 270 | 271 | // Menu bar is always up the top. 272 | screens->frames[i].y = frame.size.height - visibleFrame.size.height; 273 | screens->frames[i].x = visibleFrame.origin.x; 274 | screens->frames[i].w = visibleFrame.size.width; 275 | screens->frames[i].h = visibleFrame.size.height; 276 | 277 | i++; 278 | } 279 | 280 | return screens; 281 | } 282 | 283 | int quartzScreensLength(QuartzScreens *screens) { 284 | return screens->length; 285 | } 286 | 287 | void *quartzScreensFrame(QuartzScreens *screens, int index) { 288 | return &screens->frames[index]; 289 | } 290 | 291 | void quartzScreensFree(QuartzScreens *screens) { 292 | free(screens->frames); 293 | free(screens); 294 | } 295 | 296 | void quartzGrabKey(int keyCode, int alternative, int command, int control, int shift) { 297 | NSUInteger modifierFlags = 0; 298 | if (alternative) { 299 | modifierFlags |= NSAlternateKeyMask; 300 | } 301 | if (command) { 302 | modifierFlags |= NSCommandKeyMask; 303 | } 304 | if (control) { 305 | modifierFlags |= NSControlKeyMask; 306 | } 307 | if (shift) { 308 | modifierFlags |= NSShiftKeyMask; 309 | } 310 | QuartzGrabbedKey *key = [[QuartzGrabbedKey alloc] initWithKeyCode:keyCode modifierFlags:modifierFlags]; 311 | [quartzGrabbedKeys addObject:key]; 312 | } 313 | 314 | void *quartzEvent() { 315 | NSEvent *event = [NSApp nextEventMatchingMask:NSAnyEventMask untilDate:[NSDate distantFuture] inMode:NSDefaultRunLoopMode dequeue:YES]; 316 | IREvent *irEvent = malloc(sizeof(irEvent)); 317 | 318 | switch ([event type]) { 319 | case NSKeyDown: 320 | irEvent->type = IRKeyDownEventType; 321 | irEvent->keyCode = [event keyCode]; 322 | irEvent->modifiers = 0; 323 | if ([event modifierFlags] & NSAlternateKeyMask) { 324 | irEvent->modifiers |= IRKeyModifierAlternate; 325 | } 326 | if ([event modifierFlags] & NSCommandKeyMask) { 327 | irEvent->modifiers |= IRKeyModifierCommand; 328 | } 329 | if ([event modifierFlags] & NSControlKeyMask) { 330 | irEvent->modifiers |= IRKeyModifierControl; 331 | } 332 | if ([event modifierFlags] & NSShiftKeyMask) { 333 | irEvent->modifiers |= IRKeyModifierShift; 334 | } 335 | break; 336 | case NSApplicationDefined: 337 | switch ([event subtype]) { 338 | case QuartzApplicationDeactivateEvent: 339 | // Focused application changed. 340 | irEvent->type = IRRefreshEventType; 341 | break; 342 | } 343 | break; 344 | default: 345 | irEvent->type = IRIgnoredEventType; 346 | break; 347 | } 348 | 349 | return irEvent; 350 | } 351 | -------------------------------------------------------------------------------- /cbits/quartz_stubs.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef void *CGSConnectionID; 4 | extern CGSConnectionID _CGSDefaultConnection(void); 5 | #define CGSDefaultConnection _CGSDefaultConnection() 6 | 7 | typedef enum _CGSSpaceSelector { 8 | kCGSSpaceCurrent = 5, 9 | kCGSSpaceOther = 6, 10 | kCGSSpaceAll = 7 11 | } CGSSpaceSelector; 12 | 13 | extern CFArrayRef CGSCopySpaces(const CGSConnectionID, CGSSpaceSelector); 14 | 15 | // Private API: Stable identifier for a window. 16 | extern AXError _AXUIElementGetWindow(AXUIElementRef, CGWindowID*); 17 | -------------------------------------------------------------------------------- /iridium-quartz.ipkg: -------------------------------------------------------------------------------- 1 | package iridiumquartz 2 | 3 | main = Quartz 4 | sourcedir = src 5 | makefile = MakefileC 6 | 7 | objs = quartz.o, quartz.h, ir.o, ir.h 8 | -------------------------------------------------------------------------------- /src/IR.idr: -------------------------------------------------------------------------------- 1 | module IR 2 | 3 | import Control.Monad.Identity 4 | import Data.SortedMap 5 | import Effect.State 6 | import IR.Event 7 | import IR.Lens 8 | import IR.Reader 9 | 10 | %default total 11 | 12 | record Rectangle : Type where 13 | MkRectangle : (rectX : Float) -> 14 | (rectY : Float) -> 15 | (rectW : Float) -> 16 | (rectH : Float) -> 17 | Rectangle 18 | 19 | rectX' : Lens Rectangle Float 20 | rectX' = lens (\(MkRectangle x _ _ _) => x) (\x, (MkRectangle _ a b c) => MkRectangle x a b c) 21 | 22 | rectY' : Lens Rectangle Float 23 | rectY' = lens (\(MkRectangle _ x _ _) => x) (\x, (MkRectangle a _ b c) => MkRectangle a x b c) 24 | 25 | rectW' : Lens Rectangle Float 26 | rectW' = lens (\(MkRectangle _ _ x _) => x) (\x, (MkRectangle a b _ c) => MkRectangle a b x c) 27 | 28 | rectH' : Lens Rectangle Float 29 | rectH' = lens (\(MkRectangle _ _ _ x) => x) (\x, (MkRectangle a b c _) => MkRectangle a b c x) 30 | 31 | record Stack : Type -> Type where 32 | MkStack : (stackFocus : wid) -> 33 | (stackUp : List wid) -> 34 | (stackDown : List wid) -> 35 | Stack wid 36 | 37 | stackFocus' : Lens (Stack wid) wid 38 | stackFocus' = lens (\(MkStack x _ _) => x) (\x, (MkStack _ a b) => MkStack x a b) 39 | 40 | stackUp' : Lens (Stack wid) (List wid) 41 | stackUp' = lens (\(MkStack _ x _) => x) (\x, (MkStack a _ b) => MkStack a x b) 42 | 43 | stackDown' : Lens (Stack wid) (List wid) 44 | stackDown' = lens (\(MkStack _ _ x) => x) (\x, (MkStack a b _) => MkStack a b x) 45 | 46 | stackLength : Stack wid -> Nat 47 | stackLength (MkStack _ ys zs) = S (length ys + length zs) 48 | 49 | LayoutF : Type -> Type 50 | LayoutF wid = Rectangle -> (s : Stack wid) -> Vect (stackLength s) (wid, Rectangle) 51 | 52 | record Layout : Type -> Type where 53 | MkLayout : (layoutPure : LayoutF wid) -> 54 | (layoutNext : Inf (Layout wid)) -> 55 | Layout wid 56 | 57 | layoutPure' : Lens (Layout wid) (LayoutF wid) 58 | layoutPure' = lens (\(MkLayout x _) => x) (\x, (MkLayout _ a) => MkLayout x a) 59 | 60 | layoutNext' : Lens (Layout wid) (Layout wid) 61 | layoutNext' = lens (\(MkLayout _ x) => x) (\x, (MkLayout a _) => MkLayout a x) 62 | 63 | record Workspace : Type -> Type where 64 | MkWorkspace : (workspaceLayout : Layout wid) -> 65 | (workspaceStack : Maybe (Stack wid)) -> 66 | Workspace wid 67 | 68 | workspaceLayout' : Lens (Workspace wid) (Layout wid) 69 | workspaceLayout' = lens (\(MkWorkspace x _) => x) (\x, (MkWorkspace _ a) => MkWorkspace x a) 70 | 71 | workspaceStack' : Lens (Workspace wid) (Maybe (Stack wid)) 72 | workspaceStack' = lens (\(MkWorkspace _ x) => x) (\x, (MkWorkspace a _) => MkWorkspace a x) 73 | 74 | record Screen : Type -> Type -> Type where 75 | MkScreen : (screenWorkspace : Workspace wid) -> 76 | (screenId : sid) -> 77 | (screenDetail : Rectangle) -> 78 | Screen wid sid 79 | 80 | screenWorkspace' : Lens (Screen wid sid) (Workspace wid) 81 | screenWorkspace' = lens (\(MkScreen x _ _) => x) (\x, (MkScreen _ a b) => MkScreen x a b) 82 | 83 | screenDetail' : Lens (Screen wid sid) Rectangle 84 | screenDetail' = lens (\(MkScreen _ _ x) => x) (\x, (MkScreen a b _) => MkScreen a b x) 85 | 86 | record StackSet : Type -> Type -> Type where 87 | MkStackSet : (stackSetCurrent : Screen wid sid) -> 88 | (stackSetVisible : List (Screen wid sid)) -> 89 | (stackSetHidden : List (Workspace wid)) -> 90 | StackSet wid sid 91 | 92 | stackSetCurrent' : Lens (StackSet wid sid) (Screen wid sid) 93 | stackSetCurrent' = lens (\(MkStackSet x _ _) => x) (\x, (MkStackSet _ a b) => MkStackSet x a b) 94 | 95 | record IRState : Type -> Type -> Type where 96 | MkIRState : (irStateStackSet : StackSet wid sid) -> 97 | IRState wid sid 98 | 99 | irStateStackSet' : Lens (IRState wid sid) (StackSet wid sid) 100 | irStateStackSet' = lens (\(MkIRState x) => x) (\x, (MkIRState _) => MkIRState x) 101 | 102 | data IREffect : Type -> Type -> Effect where 103 | GetEvent : { () } (IREffect wid sid) Event 104 | GetFrames : { () } (IREffect wid sid) (n ** Vect (S n) Rectangle) 105 | GetWindows : { () } (IREffect wid sid) (List wid) 106 | GrabKeys : List Key -> { () } (IREffect wid sid) () 107 | RefreshState : IRState wid sid -> { () } (IREffect wid sid) (IRState wid sid) 108 | SetFocus : wid -> { () } (IREffect wid sid) () 109 | TileWindow : wid -> Rectangle -> { () } (IREffect wid sid) () 110 | 111 | IR : Type -> Type -> EFFECT 112 | IR wid sid = MkEff () (IREffect wid sid) 113 | 114 | record IRConf : Type -> Type -> Type where 115 | MkIRConf : (irConfKeyActions : SortedMap Key ({ [IR wid sid, STATE (IRState wid sid)] } Eff ())) -> 116 | IRConf wid sid 117 | 118 | irConfKeyActions' : Lens (IRConf wid sid) (SortedMap Key ({ [IR wid sid, STATE (IRState wid sid)] } Eff ())) 119 | irConfKeyActions' = lens (\(MkIRConf x) => x) (\x, (MkIRConf _) => MkIRConf x) 120 | 121 | getEvent : { [IR wid sid] } Eff Event 122 | getEvent = call GetEvent 123 | 124 | grabKeys : List Key -> { [IR wid sid] } Eff () 125 | grabKeys k = call (GrabKeys k) 126 | 127 | setFocus : wid -> { [IR wid sid] } Eff () 128 | setFocus wid = call (SetFocus wid) 129 | 130 | tileWindow : wid -> Rectangle -> { [IR wid sid] } Eff () 131 | tileWindow wid rect = call (TileWindow wid rect) 132 | 133 | runLayout : { [IR wid sid, STATE (IRState wid sid)] } Eff () 134 | runLayout = do 135 | s <- get 136 | let screen = stackSetCurrent' . irStateStackSet' ^$ s 137 | let frame : Rectangle = screenDetail' ^$ screen 138 | -- Idris bug: maybe doesn't work here, have to use fromMaybe 139 | let maybeStack = workspaceStack' . screenWorkspace' ^$ screen 140 | let l = layoutPure' . workspaceLayout' . screenWorkspace' ^$ screen 141 | case maybeStack of 142 | Just stack => do 143 | mapVE (uncurry tileWindow) (l frame stack) 144 | setFocus (stackFocus' ^$ stack) 145 | return () 146 | Nothing => return () 147 | 148 | refresh : { [IR wid sid, STATE (IRState wid sid)] } Eff () 149 | refresh = do 150 | s <- get 151 | s' <- call (RefreshState s) 152 | put s' 153 | runLayout 154 | 155 | getFrames : { [IR wid sid] } Eff (n ** Vect (S n) Rectangle) 156 | getFrames = call GetFrames 157 | 158 | getWindows : { [IR wid sid] } Eff (List wid) 159 | getWindows = call GetWindows 160 | 161 | nextLayout : IRState wid sid -> IRState wid sid 162 | nextLayout = workspaceLayout' . screenWorkspace' . stackSetCurrent' . irStateStackSet' ^%= getL layoutNext' 163 | 164 | handleEvent : Event -> { [IR wid sid, STATE (IRState wid sid), READER (IRConf wid sid)] } Eff () 165 | handleEvent RefreshEvent = refresh 166 | handleEvent (KeyEvent key) = do 167 | conf <- ask 168 | -- Idris bug: can't inline this let 169 | let m = lookup key (irConfKeyActions' ^$ conf) 170 | fromMaybe (return ()) m 171 | return () 172 | handleEvent IgnoredEvent = return () 173 | 174 | partial 175 | runIR' : { [IR wid sid, STATE (IRState wid sid), READER (IRConf wid sid)] } Eff () 176 | runIR' = do 177 | e <- getEvent 178 | handleEvent e 179 | runIR' 180 | 181 | partial 182 | runIR : { [IR wid sid, STATE (IRState wid sid), READER (IRConf wid sid)] } Eff () 183 | runIR = do 184 | conf <- ask 185 | grabKeys (map fst (toList (irConfKeyActions' ^$ conf))) 186 | runLayout 187 | runIR' 188 | -------------------------------------------------------------------------------- /src/IR/Event.idr: -------------------------------------------------------------------------------- 1 | module IR.Event 2 | 3 | import IR.Lens 4 | 5 | KeyCode : Type 6 | KeyCode = Int 7 | 8 | record Key : Type where 9 | MkKey : (keyCode : KeyCode) -> 10 | (keyHasAlt : Bool) -> 11 | (keyHasCmd : Bool) -> 12 | (keyHasCtrl : Bool) -> 13 | (keyHasShift : Bool) -> 14 | Key 15 | 16 | instance Eq Key where 17 | (==) (MkKey a b c d e) (MkKey a' b' c' d' e') = a == a' && b == b' && c == c' && d == d' && e == e' 18 | 19 | -- Should be the Monoid instance: 20 | infixl 3 21 | () : Ordering -> Ordering -> Ordering 22 | () EQ r = r 23 | () l r = l 24 | 25 | -- Should be the Ord instance: 26 | compareBool : Bool -> Bool -> Ordering 27 | compareBool False False = EQ 28 | compareBool False True = LT 29 | compareBool True False = GT 30 | compareBool True True = EQ 31 | 32 | instance Ord Key where 33 | compare (MkKey a b c d e) (MkKey a' b' c' d' e') = compare a a' 34 | compareBool b b' 35 | compareBool c c' 36 | compareBool d d' 37 | compareBool e e' 38 | 39 | keyCode' : Lens Key KeyCode 40 | keyCode' = lens (\(MkKey x _ _ _ _) => x) (\x, (MkKey _ a b c d) => MkKey x a b c d) 41 | 42 | keyHasAlt' : Lens Key Bool 43 | keyHasAlt' = lens (\(MkKey _ x _ _ _) => x) (\x, (MkKey a _ b c d) => MkKey a x b c d) 44 | 45 | keyHasCmd' : Lens Key Bool 46 | keyHasCmd' = lens (\(MkKey _ _ x _ _) => x) (\x, (MkKey a b _ c d) => MkKey a b x c d) 47 | 48 | keyHasCtrl' : Lens Key Bool 49 | keyHasCtrl' = lens (\(MkKey _ _ _ x _) => x) (\x, (MkKey a b c _ d) => MkKey a b c x d) 50 | 51 | keyHasShift' : Lens Key Bool 52 | keyHasShift' = lens (\(MkKey _ _ _ _ x) => x) (\x, (MkKey a b c d _) => MkKey a b c d x) 53 | 54 | data Event = KeyEvent Key 55 | | RefreshEvent 56 | | IgnoredEvent 57 | 58 | eventFromPtr : Ptr -> IO Event 59 | eventFromPtr p = do 60 | t <- mkForeign (FFun "irEventType" [FPtr] FInt) p 61 | c <- mkForeign (FFun "irEventKeyCode" [FPtr] FInt) p 62 | alt <- map (/= 0) (mkForeign (FFun "irEventKeyAlternate" [FPtr] FInt) p) 63 | cmd <- map (/= 0) (mkForeign (FFun "irEventKeyCommand" [FPtr] FInt) p) 64 | ctrl <- map (/= 0) (mkForeign (FFun "irEventKeyControl" [FPtr] FInt) p) 65 | shift <- map (/= 0) (mkForeign (FFun "irEventKeyShift" [FPtr] FInt) p) 66 | mkForeign (FFun "irEventFree" [FPtr] FUnit) p 67 | return (case t of 68 | 0 => KeyEvent (MkKey c alt cmd ctrl shift) 69 | 1 => RefreshEvent 70 | _ => IgnoredEvent) 71 | -------------------------------------------------------------------------------- /src/IR/Layout.idr: -------------------------------------------------------------------------------- 1 | module IR.Layout 2 | 3 | import IR 4 | import IR.StackSet 5 | 6 | %default total 7 | 8 | column : Rectangle -> (n : Nat) -> Vect n Rectangle 9 | column r n = column' n r n 10 | where column' _ _ Z = [] 11 | column' n (MkRectangle x y w h) (S m) = 12 | let w' = w / fromInteger (toIntegerNat n) 13 | in MkRectangle (x + w' * fromInteger (toIntegerNat m)) y w' h :: column' n r m 14 | 15 | fullLayout : LayoutF wid 16 | fullLayout rect s = zip (integrate s) (replicate (stackLength s) rect) 17 | 18 | columnLayout : LayoutF wid 19 | columnLayout rect s = zip (integrate s) (column rect (stackLength s)) 20 | 21 | mirrorLayout : LayoutF wid -> LayoutF wid 22 | mirrorLayout l (MkRectangle x' y' w' h') s = map (\(wid, MkRectangle x y w h) => (wid, MkRectangle ((y - y') / h' * w' + x') ((x - x') / w' * h' + y') (h / h' * w') (w / w' * h'))) (l (MkRectangle x' y' w' h') s) 23 | 24 | single : LayoutF wid -> Layout wid 25 | single l = x 26 | where x = MkLayout l x 27 | 28 | choose : Vect (S n) (LayoutF wid) -> Layout wid 29 | choose {n} {wid} (x::xs) = 30 | let xs' : Vect (S n) (LayoutF wid) = rewrite plusCommutative 1 n in xs ++ [x] 31 | in MkLayout x (choose xs') 32 | -------------------------------------------------------------------------------- /src/IR/Lens.idr: -------------------------------------------------------------------------------- 1 | module IR.Lens 2 | 3 | import Control.Category 4 | 5 | data Store s a = MkStore (s -> a) s 6 | 7 | class Functor w => Comonad (w : Type -> Type) where 8 | extract : w a -> a 9 | extend : (w a -> b) -> w a -> w b 10 | 11 | class Comonad w => VerifiedComonad (w : Type -> Type) where 12 | comonadLaw1 : (wa : w a) -> 13 | extend extract wa = wa 14 | comonadLaw2 : (f : w a -> b) -> 15 | (wa : w a) -> 16 | extract (extend f wa) = f wa 17 | comonadLaw3 : (f : w b -> c) -> 18 | (g : w a -> b) -> 19 | (wa : w a) -> 20 | extend f (extend g wa) = extend (\d => f (extend g d)) wa 21 | 22 | instance Functor (Store s) where 23 | map f (MkStore g a) = MkStore (f . g) a 24 | 25 | instance Comonad (Store s) where 26 | extract (MkStore f a) = f a 27 | extend f (MkStore g a) = MkStore (\b => f (MkStore g b)) a 28 | 29 | instance VerifiedComonad (Store s) where 30 | comonadLaw1 (MkStore f a) = ?storeIdentityProof 31 | comonadLaw2 f (MkStore g a) = refl 32 | comonadLaw3 f g (MkStore h a) = refl 33 | 34 | -- TODO: This is evil. 35 | -- Supposedly (jonsterling) this definition used to work without the believe_me. 36 | eta : (f : a -> b) -> f = (\c => f c) 37 | eta g = believe_me refl {g} 38 | 39 | storeIdentityProof = proof 40 | intros 41 | rewrite eta f 42 | trivial 43 | 44 | pos : Store s a -> s 45 | pos (MkStore _ s) = s 46 | 47 | peek : s -> Store s a -> a 48 | peek s (MkStore f _) = f s 49 | 50 | peeks : (s -> s) -> Store s a -> a 51 | peeks f (MkStore g s) = g (f s) 52 | 53 | data Lens a b = MkLens (a -> Store b a) 54 | 55 | instance Category Lens where 56 | id = MkLens (MkStore id) 57 | (.) (MkLens f) (MkLens g) = MkLens (\a => case g a of 58 | MkStore ba b => case f b of 59 | MkStore cb c => MkStore (Prelude.Basics.(.) ba cb) c) 60 | 61 | lens : (a -> b) -> (b -> a -> a) -> Lens a b 62 | lens f g = MkLens (\a => MkStore (\b => g b a) (f a)) 63 | 64 | iso : (a -> b) -> (b -> a) -> Lens a b 65 | iso f g = MkLens (\a => MkStore g (f a)) 66 | 67 | getL : Lens a b -> a -> b 68 | getL (MkLens f) a = pos (f a) 69 | 70 | setL : Lens a b -> b -> a -> a 71 | setL (MkLens f) b = peek b . f 72 | 73 | modL : Lens a b -> (b -> b) -> a -> a 74 | modL (MkLens f) g = peeks g . f 75 | 76 | infixr 0 ^$ 77 | (^$) : Lens a b -> a -> b 78 | (^$) = getL 79 | 80 | infixr 4 ^= 81 | (^=) : Lens a b -> b -> a -> a 82 | (^=) = setL 83 | 84 | infixr 4 ^%= 85 | (^%=) : Lens a b -> (b -> b) -> a -> a 86 | (^%=) = modL 87 | -------------------------------------------------------------------------------- /src/IR/Reader.idr: -------------------------------------------------------------------------------- 1 | module IR.Reader 2 | 3 | import Effects 4 | 5 | data Reader : Effect where 6 | Ask : { a } Reader a 7 | 8 | instance Handler Reader m where 9 | handle st Ask k = k st st 10 | 11 | READER : Type -> EFFECT 12 | READER t = MkEff t Reader 13 | 14 | ask : { [READER x] } Eff x 15 | ask = call Ask 16 | -------------------------------------------------------------------------------- /src/IR/StackSet.idr: -------------------------------------------------------------------------------- 1 | module IR.StackSet 2 | 3 | import IR 4 | import IR.Lens 5 | 6 | manage : Eq wid => wid -> Workspace wid -> Workspace wid 7 | manage wid (MkWorkspace l Nothing) = MkWorkspace l (Just (MkStack wid [] [])) 8 | manage wid (MkWorkspace l (Just (MkStack wid' a b))) = MkWorkspace l (Just (MkStack wid a (wid' :: b))) 9 | 10 | integrate : (s : Stack wid) -> Vect (stackLength s) wid 11 | integrate (MkStack x ys zs) = 12 | rewrite plusSuccRightSucc (length ys) (length zs) 13 | in reverse (fromList ys) ++ x :: fromList zs 14 | 15 | member : Eq wid => wid -> StackSet wid sid -> Bool 16 | member wid s = 17 | maybe False (\stack => elem wid (integrate stack)) (workspaceStack' . screenWorkspace' . stackSetCurrent' ^$ s) 18 | 19 | filter : (wid -> Bool) -> Stack wid -> Maybe (Stack wid) 20 | filter p (MkStack f ls rs) = case filter p (f::rs) of 21 | f'::rs' => Just (MkStack f' (filter p ls) rs') 22 | [] => case filter p ls of 23 | f'::ls' => Just (MkStack f' ls' []) 24 | [] => Nothing 25 | 26 | stackSetStack : Lens (StackSet wid sid) (Maybe (Stack wid)) 27 | stackSetStack = workspaceStack' . screenWorkspace' . stackSetCurrent' 28 | 29 | -- TODO: Use more than stackSetCurrent' 30 | delete : Eq wid => wid -> StackSet wid sid -> StackSet wid sid 31 | delete wid = stackSetStack ^%= (>>= filter (/= wid)) 32 | 33 | insertUp : Eq wid => wid -> StackSet wid sid -> StackSet wid sid 34 | insertUp wid s = if member wid s then s else insert 35 | where insert = workspaceStack' . screenWorkspace' . stackSetCurrent' ^%= Just . maybe (MkStack wid [] []) (\(MkStack t l r) => MkStack wid l (t::r)) $ s 36 | 37 | modify' : (Stack wid -> Stack wid) -> StackSet wid sid -> StackSet wid sid 38 | modify' f = stackSetStack ^%= map f 39 | 40 | stackSetPeek : StackSet wid sid -> Maybe wid 41 | stackSetPeek ss = map (\s => stackFocus' ^$ s) (stackSetStack ^$ ss) 42 | 43 | reverseStack : Stack wid -> Stack wid 44 | reverseStack (MkStack t ls rs) = MkStack t rs ls 45 | 46 | focusUp' : Stack wid -> Stack wid 47 | focusUp' (MkStack t [] []) = MkStack t [] [] 48 | focusUp' (MkStack t (l::ls) rs) = MkStack l ls (t::rs) 49 | focusUp' (MkStack t [] rs) = 50 | let (x::xs) = reverse (t::fromList rs) 51 | in MkStack x (toList xs) [] 52 | 53 | focusDown' : Stack wid -> Stack wid 54 | focusDown' = reverseStack . focusUp' . reverseStack 55 | 56 | focusDown : StackSet wid sid -> StackSet wid sid 57 | focusDown = modify' focusDown' 58 | 59 | focusUp : StackSet wid sid -> StackSet wid sid 60 | focusUp = modify' focusUp' 61 | 62 | focusWindow : Eq wid => wid -> StackSet wid sid -> StackSet wid sid 63 | focusWindow wid s = fromMaybe s (find ((== Just wid) . stackSetPeek) (take (maybe 0 stackLength (stackSetStack ^$ s)) (iterate focusUp s))) 64 | 65 | swapUp' : Stack wid -> Stack wid 66 | swapUp' (MkStack t (l::ls) rs) = MkStack t ls (l::rs) 67 | swapUp' (MkStack t [] rs) = MkStack t (reverse rs) [] 68 | 69 | swapUp : StackSet wid sid -> StackSet wid sid 70 | swapUp = modify' swapUp' 71 | 72 | swapDown : StackSet wid sid -> StackSet wid sid 73 | swapDown = modify' (reverseStack . swapUp' . reverseStack) 74 | 75 | windows : (StackSet wid sid -> StackSet wid sid) -> { [IR wid sid, STATE (IRState wid sid)] } Eff () 76 | windows f = do 77 | update (irStateStackSet' ^%= f) 78 | runLayout 79 | -------------------------------------------------------------------------------- /src/MakefileC: -------------------------------------------------------------------------------- 1 | VPATH = ../cbits 2 | 3 | CFLAGS := -Wall 4 | 5 | all: quartz.o ir.o 6 | 7 | quartz.o: quartz.m quartz.h 8 | 9 | ir.o: ir.c ir.h 10 | 11 | .PHONY: clean 12 | clean: 13 | rm quartz.o 14 | rm ir .o 15 | -------------------------------------------------------------------------------- /src/Quartz.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import IR 4 | import IR.Event 5 | import IR.Layout 6 | import IR.Lens 7 | import IR.StackSet 8 | 9 | %flag C "-framework Cocoa" 10 | %include C "cbits/quartz.h" 11 | %link C "src/quartz.o" 12 | %include C "cbits/ir.h" 13 | %link C "src/ir.o" 14 | 15 | %default total 16 | 17 | partial 18 | putErrLn : String -> IO () 19 | putErrLn s = fwrite stderr (s ++ "\n") 20 | 21 | quartzInit : IO Bool 22 | quartzInit = map (/= 0) (mkForeign (FFun "quartzInit" [] FInt)) 23 | 24 | quartzSpacesCount : IO Int 25 | quartzSpacesCount = mkForeign (FFun "quartzSpacesCount" [] FInt) 26 | 27 | QuartzWindow : Type 28 | QuartzWindow = Int 29 | 30 | QuartzSpace : Type 31 | QuartzSpace = Int 32 | 33 | QuartzState : Type 34 | QuartzState = IRState QuartzWindow QuartzSpace 35 | 36 | QUARTZ : EFFECT 37 | QUARTZ = IR QuartzWindow QuartzSpace 38 | 39 | quartzGetWindows : IO (List QuartzWindow, QuartzWindow) 40 | quartzGetWindows = do 41 | p <- mkForeign (FFun "quartzWindows" [] FPtr) 42 | l <- mkForeign (FFun "quartzWindowsLength" [FPtr] FInt) p 43 | wids <- traverse (\a => mkForeign (FFun "quartzWindowId" [FPtr, FInt] FInt) p a) [0..l-1] 44 | focused <- mkForeign (FFun "quartzWindowsFocusedId" [FPtr] FInt) p 45 | mkForeign (FFun "quartzWindowsFree" [FPtr] FUnit) p 46 | return (wids, focused) 47 | 48 | quartzTileWindow : QuartzWindow -> Rectangle -> IO () 49 | quartzTileWindow wid r = 50 | mkForeign (FFun "quartzWindowSetRect" [FInt, FFloat, FFloat, FFloat, FFloat] FUnit) wid (rectX r) (rectY r) (rectW r) (rectH r) 51 | 52 | quartzFocusWindow : QuartzWindow -> IO () 53 | quartzFocusWindow wid = 54 | mkForeign (FFun "quartzWindowSetFocus" [FInt] FUnit) wid 55 | 56 | quartzRefresh : QuartzState -> IO QuartzState 57 | quartzRefresh s = do 58 | (wids, focused) <- quartzGetWindows 59 | let stack = workspaceStack' . screenWorkspace' . stackSetCurrent' . irStateStackSet' ^$ s 60 | let wids' = fromMaybe [] (map (\s => toList (integrate s)) stack) 61 | let deleted = wids' \\ wids 62 | let inserted = wids \\ wids' 63 | return (irStateStackSet' ^%= (\ss => focusWindow focused (foldr insertUp (foldr delete ss deleted) inserted)) $ s) 64 | 65 | quartzGetFrame : Ptr -> Int -> IO Rectangle 66 | quartzGetFrame p i = do 67 | r <- mkForeign (FFun "quartzScreensFrame" [FPtr, FInt] FPtr) p i 68 | x <- mkForeign (FFun "irFrameX" [FPtr] FFloat) r 69 | y <- mkForeign (FFun "irFrameY" [FPtr] FFloat) r 70 | w <- mkForeign (FFun "irFrameW" [FPtr] FFloat) r 71 | h <- mkForeign (FFun "irFrameH" [FPtr] FFloat) r 72 | return (MkRectangle x y w h) 73 | 74 | quartzGetFrames : IO (n ** Vect (S n) Rectangle) 75 | quartzGetFrames = do 76 | p <- mkForeign (FFun "quartzScreens" [] FPtr) 77 | l <- mkForeign (FFun "quartzScreensLength" [FPtr] FInt) p 78 | mainFrame <- quartzGetFrame p 0 79 | frames <- traverse (quartzGetFrame p) [1..l-1] 80 | mkForeign (FFun "quartzScreensFree" [FPtr] FUnit) p 81 | return (length frames ** mainFrame :: fromList frames) 82 | 83 | quartzGrabKeys : List Key -> IO () 84 | quartzGrabKeys keys = 85 | let grabKey = \key => do 86 | let c = keyCode' ^$ key 87 | let f = \b => if b then 1 else 0 88 | let alt = f $ keyHasAlt' ^$ key 89 | let cmd = f $ keyHasCmd' ^$ key 90 | let ctrl = f $ keyHasCtrl' ^$ key 91 | let shift = f $ keyHasShift' ^$ key 92 | mkForeign (FFun "quartzGrabKey" [FInt, FInt, FInt, FInt, FInt] FUnit) c alt cmd ctrl shift 93 | in traverse_ grabKey keys 94 | 95 | instance Handler (IREffect QuartzWindow QuartzSpace) IO where 96 | handle () GetEvent k = do 97 | p <- mkForeign (FFun "quartzEvent" [] FPtr) 98 | e <- eventFromPtr p 99 | k e () 100 | handle () (GrabKeys keys) k = do 101 | quartzGrabKeys keys 102 | k () () 103 | handle () (RefreshState s) k = do 104 | s' <- quartzRefresh s 105 | k s' () 106 | handle () (TileWindow wid r) k = do 107 | quartzTileWindow wid r 108 | k () () 109 | handle () (SetFocus wid) k = do 110 | quartzFocusWindow wid 111 | k () () 112 | handle () GetWindows k = do 113 | (wids, _) <- quartzGetWindows 114 | k wids () 115 | handle () GetFrames k = do 116 | f <- quartzGetFrames 117 | k f () 118 | 119 | initialQuartzState : IO (IRState QuartzWindow QuartzSpace) 120 | initialQuartzState = do 121 | (_ ** frame :: _) <- quartzGetFrames 122 | (wids, _) <- quartzGetWindows 123 | let workspace : Workspace QuartzWindow = foldr manage (MkWorkspace (choose [columnLayout, mirrorLayout columnLayout, fullLayout]) Nothing) wids 124 | return (MkIRState (MkStackSet (MkScreen workspace 0 frame) [] [])) 125 | 126 | SpacebarKeyCode : Int 127 | SpacebarKeyCode = 0x31 128 | 129 | JKeyCode : Int 130 | JKeyCode = 0x26 131 | 132 | KKeyCode : Int 133 | KKeyCode = 0x28 134 | 135 | CmdOptionSpacebar : Key 136 | CmdOptionSpacebar = MkKey SpacebarKeyCode True True False False 137 | 138 | CmdOptionJKey : Key 139 | CmdOptionJKey = MkKey JKeyCode True True False False 140 | 141 | CmdOptionShiftJKey : Key 142 | CmdOptionShiftJKey = MkKey JKeyCode True True False True 143 | 144 | CmdOptionKKey : Key 145 | CmdOptionKKey = MkKey KKeyCode True True False False 146 | 147 | CmdOptionShiftKKey : Key 148 | CmdOptionShiftKKey = MkKey KKeyCode True True False True 149 | 150 | quartzConf : IRConf QuartzWindow QuartzSpace 151 | quartzConf = 152 | MkIRConf (fromList [ 153 | (CmdOptionSpacebar, update nextLayout >>= \_ => refresh) 154 | , (CmdOptionJKey, windows focusDown) 155 | , (CmdOptionKKey, windows focusUp) 156 | , (CmdOptionShiftJKey, windows swapDown) 157 | , (CmdOptionShiftKKey, windows swapUp) 158 | ]) 159 | 160 | partial 161 | main : IO () 162 | main = do 163 | putStrLn "iridium started" 164 | a <- quartzInit 165 | if not a 166 | then do 167 | putErrLn "iridium doesn't have Accessibility permission." 168 | putErrLn "You can enable this under Privacy in Security & Privacy in System Preferences." 169 | else runInit [(), !initialQuartzState, quartzConf] runIR 170 | --------------------------------------------------------------------------------