diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2015 Sam Boosalis + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,1 @@ +import Workflow.OSX.Example diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +# workflow-osx + +a (free) monad, with Objective-C bindings, for "Workflow" actions. + +e.g. press some keys, click the mouse, get and set the clipboard. GHC's C FFI takes only microseconds. + +for examples, see the documentation on hackage + +# Issues + +## the build + +foreign dependencies always complicate the build process. it's known to work with the following: + +* OS + + $ sw_vers + ProductName: Mac OS X + ProductVersion: 10.9.5 + BuildVersion: 13F34 + +* C compiler + + $ gcc --version + Configured with: --prefix=/Applications/Xcode.app/Contents/Developer/usr --with-gxx-include-dir=/usr/include/c++/4.2.1 + Apple LLVM version 6.0 (clang-600.0.51) (based on LLVM 3.5svn) + Target: x86_64-apple-darwin13.4.0 + Thread model: posix + +* Haskell compiler + + $ ghc --version + The Glorious Glasgow Haskell Compilation System, version 7.10.1 + +# TODO + +## platform agnosticism + +exploit the free monad\'s flexibility to define platform-agnostic workflows + +problem: windows (Linux/Windows) versus processes (OS X) + +problem: keyboards. Apple keyboards don't have the Windows key, Windows keyboards don't have the Apple key. some keyboards have a dozen random extra unbound keys. + +## automatic `delay` insertion + +problem: currently, delays must be inserted manually. keyboard shortcuts in Emacs succeed with no delay. keyboard shortcuts in Chrome, like closing a tab with `M-w`, may drop without a long delay (like 250ms). furthermore, different actions need different delays between them (e.g. inserting text into Chrome can be done without delay). + +## parameterize `Workflow` on a keyboard type + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/Makefile b/cbits/Makefile new file mode 100644 --- /dev/null +++ b/cbits/Makefile @@ -0,0 +1,13 @@ +# only sets environment variables when undefined +# override with: (CC=gcc; make) +CC?=/usr/bin/gcc + +run: main + ./main + +main: main.m objc_workflow.m + $(CC) -ObjC -framework Cocoa -o ./main -Wno-deprecated-declarations $^ +# launchedApplications is /usr/bin/ deprecated, but runningApplications doesn't return application info + +clean: + rm -f main diff --git a/cbits/objc_workflow.h b/cbits/objc_workflow.h new file mode 100644 --- /dev/null +++ b/cbits/objc_workflow.h @@ -0,0 +1,18 @@ +#ifndef CBITS_OBJC_ACTOR_H +#define CBITS_OBJC_ACTOR_H 1 + +#import + +ProcessSerialNumber* getApplicationPSN(const char* s); + +void pressKey(CGEventFlags modifiers, CGKeyCode key); +void pressKeyToCurrentApplication(CGEventFlags modifiers, CGKeyCode key); +void pressKeyTo(CGEventFlags modifiers, CGKeyCode key, ProcessSerialNumber psn); +void clickMouse(CGEventFlags modifiers, CGMouseButton mouseButton, CGEventType mouseDown, CGEventType mouseUp, UInt32 numClicks); +const char* getClipboard(); +void setClipboard(const char* contents); +const char * currentApplicationPath(); +void openApplication(const char* s); +void openURL(const char* url); + +#endif diff --git a/cbits/objc_workflow.m b/cbits/objc_workflow.m new file mode 100644 --- /dev/null +++ b/cbits/objc_workflow.m @@ -0,0 +1,206 @@ +#import + +#import "objc_workflow.h" + + +/* appInfo + + // NSLog(@"%@", appInfo); + NSDictionary: { + NSApplicationBundleIdentifier = "org.gnu.Emacs"; + NSApplicationName = Emacs; + NSApplicationPath = "/Applications/Notes.app"; + NSApplicationProcessIdentifier = 40831; + NSApplicationProcessSerialNumberHigh = 0; + NSApplicationProcessSerialNumberLow = 4195328; + NSWorkspaceApplicationKey = ""; + } +*/ + + +/* ProcessSerialNumber +https: //developer.apple.com/legacy/library/documentation/Carbon/Reference/Process_Manager/index.html#//apple_ref/doc/c_ref/ProcessSerialNumber + +struct ProcessSerialNumber { unsigned long highLongOfPSN; unsigned long lowLongOfPSN; }; +typedef struct ProcessSerialNumber ProcessSerialNumber; +typedef ProcessSerialNumber* ProcessSerialNumberPtr; +*/ + + +/* CGEventPostToPSN +https://developer.apple.com/library/mac/documentation/Carbon/Reference/QuartzEventServicesRef/index.html + +void CGEventPostToPSN ( void *processSerialNumber, CGEventRef event ); +*/ + + +// private helpers + +NSString* fromUTF8(const char* s) { + return [[NSString alloc] + initWithCString:s encoding:NSUTF8StringEncoding]; +} + +const char* toUTF8(NSString* s) { + return [s cStringUsingEncoding:NSUTF8StringEncoding]; +} + +void printPSN(ProcessSerialNumber psn) { + NSLog(@"ProcessSerialNumber: {%d,%d}", psn.highLongOfPSN, psn.lowLongOfPSN); +} + +void printApplications() { + NSLog(@"launchedApplications: %@", [[NSWorkspace sharedWorkspace] launchedApplications]); +} + +// I think that uninitialized ProcessSerialNumber is always {0,0}. +// I *hope* it doesn't crash CGEventPostToPSN (hasn't yet) and that no application has both fields coinciding. +ProcessSerialNumber nullProcessSerialNumber = {0,0}; + +// returns pseudo-Just a pointer to a heap-allocated structure, must be freed. +// pseudo-Nothing if no application by that path is running +// TODO or pointer to a pointer to a structure (without a pointer can be null)? +// from full path or from name +ProcessSerialNumber* getApplicationPSN(const char* s) { + // no maybe type... + ProcessSerialNumber* psn = (ProcessSerialNumber*)malloc(sizeof(ProcessSerialNumber)); + *psn = nullProcessSerialNumber; // http://stackoverflow.com/questions/9127246/copy-struct-to-struct-in-c + + // existentially-quantified arrays... + NSArray* appInfos = [[NSWorkspace sharedWorkspace] launchedApplications]; // runningApplications + + for (NSDictionary* appInfo in appInfos) { + if (0 == strcmp(s, toUTF8([appInfo objectForKey:@"NSApplicationPath"]))) { + psn->highLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberHigh"] unsignedIntValue]; + psn->lowLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberLow"] unsignedIntValue]; + return psn; + } + } + + for (NSDictionary* appInfo in appInfos) { + if (0 == strcmp(s, toUTF8([appInfo objectForKey:@"NSApplicationName"]))) { + psn->highLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberHigh"] unsignedIntValue]; + psn->lowLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberLow"] unsignedIntValue]; + return psn; + } + } + + return psn; +} + +ProcessSerialNumber currentApplicationPSN() { + NSDictionary *appInfo = [[NSWorkspace sharedWorkspace] activeApplication]; // frontmostApplication + ProcessSerialNumber psn; + psn.highLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberHigh"] unsignedIntValue]; + psn.lowLongOfPSN = [[appInfo objectForKey:@"NSApplicationProcessSerialNumberLow"] unsignedIntValue]; + return psn; +} + + + +// public + +const char* currentApplicationPath() { + return toUTF8([[[NSWorkspace sharedWorkspace] + activeApplication] // frontmostApplication + objectForKey:@"NSApplicationPath"]); +} + +// can be full path (e.g. "/Applications/Work.app"), or just the name (e.g. "Work") +void openApplication(const char* s) { + [[NSWorkspace sharedWorkspace] launchApplication:fromUTF8(s)]; +} + +// simulates a key press from the keyboard. works in pop-ups like Alfred. +void pressKey(CGEventFlags modifiers, CGKeyCode key) { + // NSLog(@"pressKey"); // debug + CGEventSourceRef source = CGEventSourceCreate(kCGEventSourceStateHIDSystemState); // kCGEventSourceStateCombinedSessionState + + // events to press a key + CGEventRef event1 = CGEventCreateKeyboardEvent(source, key, true); // key down + CGEventRef event2 = CGEventCreateKeyboardEvent(source, key, false); // key up + + // add modifiers to event + CGEventSetFlags(event1, modifiers); + CGEventSetFlags(event2, modifiers); + + // send a keyboard event (a quartz event) "globally" + CGEventPost(kCGHIDEventTap, event1); // kCGSessionEventTap + CGEventPost(kCGHIDEventTap, event2); // kCGSessionEventTap + + // free memory + CFRelease(event1); + CFRelease(event2); + CFRelease(source); +} + +// may take up to 15s (!) when the keypresses sent to and after besides the one that's running the server +void pressKeyToCurrentApplication(CGEventFlags modifiers, CGKeyCode key) { + pressKeyTo(modifiers, key, currentApplicationPSN()); +} + +// send a keypress to a specific process/application +void pressKeyTo(CGEventFlags modifiers, CGKeyCode key, ProcessSerialNumber psn) { + + // events to press a key + CGEventRef event1 = CGEventCreateKeyboardEvent(NULL, key, true); // key down + CGEventRef event2 = CGEventCreateKeyboardEvent(NULL, key, false); // key up + + // add modifiers to event + CGEventSetFlags(event1, modifiers); + CGEventSetFlags(event2, modifiers); + + // send keyboard event to application process (a quartz event) + CGEventPostToPSN(&psn, event1); + CGEventPostToPSN(&psn, event2); + + // free memory + CFRelease(event1); + CFRelease(event2); + // psn is a struct, that's been passed by value +} + +const char* getClipboard() { + return [[[NSPasteboard generalPasteboard] + stringForType:NSStringPboardType] + cStringUsingEncoding:NSUTF8StringEncoding]; +} + +void setClipboard(const char* contents) { + [[NSPasteboard generalPasteboard] clearContents]; + [[NSPasteboard generalPasteboard] setString:fromUTF8(contents) forType:NSStringPboardType]; +} + +void openURL(const char* url) { + [[NSWorkspace sharedWorkspace] + openURL:[NSURL URLWithString: fromUTF8(url)]]; +} + + +// CGEventRef CGEventCreateMouseEvent ( CGEventSourceRef source, CGEventType mouseType, CGPoint mouseCursorPosition, CGMouseButton mouseButton ); +// http://stackoverflow.com/questions/1117065/cocoa-getting-the-current-mouse-position-on-the-screen +void clickMouse(CGEventFlags modifiers, CGMouseButton mouseButton, CGEventType mouseDown, CGEventType mouseUp, UInt32 numClicks) { + + CGPoint currentPosition = CGEventGetLocation(CGEventCreate(NULL)); + + CGEventRef eventDown = CGEventCreateMouseEvent(NULL, kCGEventOtherMouseDown, currentPosition, mouseButton); + CGEventRef eventUp = CGEventCreateMouseEvent(NULL, kCGEventOtherMouseUp, currentPosition, mouseButton); + +// hold down modifiers +CGEventSetFlags(eventDown, modifiers); +CGEventSetFlags(eventUp, modifiers); + +// click numClicks times. each click must say which it is (1st, 2nd, 3rd, etc) + +for (int nthClick=1; nthClick<=numClicks; nthClick++) { + CGEventSetIntegerValueField(eventDown, kCGMouseEventClickState, nthClick); + CGEventSetIntegerValueField(eventUp, kCGMouseEventClickState, nthClick); + CGEventPost(kCGHIDEventTap, eventDown); + CGEventPost(kCGHIDEventTap, eventUp); + } + +// free memory +CFRelease(eventDown); +CFRelease(eventUp); + +} diff --git a/sources/Workflow/OSX.hs b/sources/Workflow/OSX.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX.hs @@ -0,0 +1,97 @@ +{- | + + +Example 1: + +@ +import qualified Data.ByteString.Char8 as BS +import qualified Network.HTTP.Types.URI as WAI + +-- | google a query, in the default browser. properly encodes the url. +google :: (MonadWorkflow m) => String -> m () +google (BS.pack -> query) = do + 'openURL' (BS.unpack $ \"https:\/\/www.google.com\/search\" <> WAI.renderQuery True [(\"q\", Just query)]) +@ + + +Example 2: + +@ +-- | access the currently selected region from Haskell, via the clipboard +copy :: (MonadWorkflow m) => m String +copy = do + 'sendKeyChord' ['CommandModifier'] 'CKey' + 'delay' 250 + 'getClipboard' + +@ + + +Example 3: + +@ +import qualified Data.Char + +-- uppercase the contents of the clipboard, and paste the result +uppercase_clipboard = do + oldContents <- 'getClipboard' + let newContents = fmap Data.Char.toUpper oldContents + 'setClipboard' newContents + 'sendKeyChord' ['CommandModifier'] 'VKey' +@ + + +Example 4: + +@ +-- pause/play the first YouTube tab open in the Chrome browser, by pressing a key after full-screening it +-- +-- (this script is super-duper-robust) +youtube_toggle_sound = do + app <- 'currentApplication' -- save the currently open application + reach_youtube + 'sendKeyChord' ['CommandModifier'] 'UpKey' -- move to the top of the screen + 'delay' chromeDelay + youtube_toggle_fullscreen + 'delay' chromeDelay + 'sendKeyChord' [] 'KKey' -- pauses/plays the video + 'delay' chromeDelay + youtube_toggle_fullscreen + 'delay' 2000 + 'openApplication' app -- restore the previously open application + +youtube_toggle_fullscreen = do + 'sendKeyChord' ['ShiftModifier'] 'FKey' + +reach_youtube = do + 'openApplication' "Google Chrome" + 'switch_tab' "YouTube.com" + +switch_tab s = do + 'sendKeyChord' ['OptionModifier'] 'TKey' -- needs the chrome extension + 'delay' chromeDelay + 'sendText' s + 'sendKeyChord' [] 'ReturnKey' + +chromeDelay = 250 -- milliseconds +@ + + +-} +module Workflow.OSX + ( module Workflow.OSX.Types + , module Workflow.OSX.DSL + , module Workflow.OSX.Bindings.Raw + , module Workflow.OSX.Constants + , module Workflow.OSX.Marshall + , module Workflow.OSX.Execute + ) where + +import Workflow.OSX.DSL +import Workflow.OSX.Types +-- import Workflow.OSX.Bindings -- names conflict with Workflow.OSX.DSL +import Workflow.OSX.Bindings.Raw +import Workflow.OSX.Constants +import Workflow.OSX.Execute +import Workflow.OSX.Marshall + diff --git a/sources/Workflow/OSX/Bindings.hs b/sources/Workflow/OSX/Bindings.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Bindings.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ViewPatterns #-} +module Workflow.OSX.Bindings where +import Workflow.OSX.Bindings.Raw +import Workflow.OSX.Marshall +import Workflow.OSX.Types + +import Foreign.C.String (peekCString, withCString) + + +currentApplication :: IO Application +currentApplication = do -- TODO munge, default to Global + path <- currentApplicationPath + return path + +-- | +-- TODO Applications whose name/paths have Unicode characters may or may not marshall correctly. +currentApplicationPath :: IO String +currentApplicationPath = objc_currentApplicationPath >>= peekCString + +-- | +pressKey :: [Modifier] -> Key -> IO () +pressKey (encodeModifiers -> flags) (encodeKey -> key) = + objc_pressKey flags key + +-- TODO | +-- clickMouse :: [Modifier] -> Positive -> MouseButton -> IO () +-- clickMouse (MouseClick (encodeModifiers -> flags) (encodePositive -> n) (encodeButton -> button)) = objc_clickMouse + +-- | +getClipboard :: IO ClipboardText +getClipboard = objc_getClipboard >>= peekCString + +-- | +-- +-- note: unlike the keyboard shortcuts of 'copy', +-- contents don't show up in Alfred's clipboard history. +setClipboard :: ClipboardText -> IO () +setClipboard s = withCString s objc_setClipboard + +-- | +openURL :: URL -> IO () +openURL s = withCString s objc_openURL + +-- | +openApplication :: Application -> IO () +openApplication s = withCString s objc_openApplication + diff --git a/sources/Workflow/OSX/Bindings/Raw.hs b/sources/Workflow/OSX/Bindings/Raw.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Bindings/Raw.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Workflow.OSX.Bindings.Raw where +import Workflow.OSX.Types + +import Foreign.C.String (CString) +import Foreign.C.Types (CULLong (..), CUShort (..)) +-- import Data.Word (Word32) + + +foreign import ccall safe "objc_workflow.h currentApplicationPath" objc_currentApplicationPath + :: IO CString + +foreign import ccall safe "objc_workflow.h pressKey" objc_pressKey + :: CGEventFlags + -> CGKeyCode + -> IO () + +-- foreign import ccall safe "objc_workflow.h clickMouse" objc_clickMouse +-- :: CGEventType +-- -> CGEventFlags +-- -> CGEventType +-- -> CGMouseButton +-- -> Word32 +-- -> IO () + +foreign import ccall safe "objc_workflow.h getClipboard" objc_getClipboard + :: IO CString + +foreign import ccall safe "objc_workflow.h setClipboard" objc_setClipboard + :: CString + -> IO () + +foreign import ccall safe "objc_workflow.h openURL" objc_openURL + :: CString + -> IO () + +foreign import ccall safe "objc_workflow.h openApplication" objc_openApplication + :: CString + -> IO () + diff --git a/sources/Workflow/OSX/Constants.hs b/sources/Workflow/OSX/Constants.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Constants.hs @@ -0,0 +1,107 @@ +module Workflow.OSX.Constants where +import Workflow.OSX.Types + +import Data.BitVector + + +-- | line 236 of +-- +-- +marshallMask :: Modifier -> BitVector +marshallMask CommandModifier = 0x00100000 +marshallMask ControlModifier = 0x00040000 +marshallMask ShiftModifier = 0x00020000 +marshallMask OptionModifier = 0x00080000 +marshallMask FunctionModifier = 0x00800000 + +-- yes: #define NX_CONTROLMASK 0x00040000 +-- no: #define NX_DEVICELCTLKEYMASK 0x00000001 +-- no: #define NX_DEVICERCTLKEYMASK 0x00002000 + +-- | line 196 of +-- +marshallKeycode :: Key -> BitVector +marshallKeycode AKey = 0x00 +marshallKeycode SKey = 0x01 +marshallKeycode DKey = 0x02 +marshallKeycode FKey = 0x03 +marshallKeycode HKey = 0x04 +marshallKeycode GKey = 0x05 +marshallKeycode ZKey = 0x06 +marshallKeycode XKey = 0x07 +marshallKeycode CKey = 0x08 +marshallKeycode VKey = 0x09 +marshallKeycode BKey = 0x0B +marshallKeycode QKey = 0x0C +marshallKeycode WKey = 0x0D +marshallKeycode EKey = 0x0E +marshallKeycode RKey = 0x0F +marshallKeycode YKey = 0x10 +marshallKeycode TKey = 0x11 +marshallKeycode OneKey = 0x12 +marshallKeycode TwoKey = 0x13 +marshallKeycode ThreeKey = 0x14 +marshallKeycode FourKey = 0x15 +marshallKeycode SixKey = 0x16 +marshallKeycode FiveKey = 0x17 +marshallKeycode EqualKey = 0x18 +marshallKeycode NineKey = 0x19 +marshallKeycode SevenKey = 0x1A +marshallKeycode MinusKey = 0x1B +marshallKeycode EightKey = 0x1C +marshallKeycode ZeroKey = 0x1D +marshallKeycode RightBracketKey = 0x1E +marshallKeycode OKey = 0x1F +marshallKeycode UKey = 0x20 +marshallKeycode LeftBracketKey = 0x21 +marshallKeycode IKey = 0x22 +marshallKeycode PKey = 0x23 +marshallKeycode LKey = 0x25 +marshallKeycode JKey = 0x26 +marshallKeycode QuoteKey = 0x27 +marshallKeycode KKey = 0x28 +marshallKeycode SemicolonKey = 0x29 +marshallKeycode BackslashKey = 0x2A +marshallKeycode CommaKey = 0x2B +marshallKeycode SlashKey = 0x2C +marshallKeycode NKey = 0x2D +marshallKeycode MKey = 0x2E +marshallKeycode PeriodKey = 0x2F +marshallKeycode GraveKey = 0x32 +marshallKeycode ReturnKey = 0x24 +marshallKeycode TabKey = 0x30 +marshallKeycode SpaceKey = 0x31 +marshallKeycode DeleteKey = 0x33 +marshallKeycode EscapeKey = 0x35 +marshallKeycode CommandKey = 0x37 +marshallKeycode ShiftKey = 0x38 +marshallKeycode CapsLockKey = 0x39 +marshallKeycode OptionKey = 0x3A +marshallKeycode ControlKey = 0x3B +marshallKeycode FunctionKey = 0x3F +marshallKeycode F17Key = 0x40 +marshallKeycode F18Key = 0x4F +marshallKeycode F19Key = 0x50 +marshallKeycode F20Key = 0x5A +marshallKeycode F5Key = 0x60 +marshallKeycode F6Key = 0x61 +marshallKeycode F7Key = 0x62 +marshallKeycode F3Key = 0x63 +marshallKeycode F8Key = 0x64 +marshallKeycode F9Key = 0x65 +marshallKeycode F11Key = 0x67 +marshallKeycode F13Key = 0x69 +marshallKeycode F16Key = 0x6A +marshallKeycode F14Key = 0x6B +marshallKeycode F10Key = 0x6D +marshallKeycode F12Key = 0x6F +marshallKeycode F15Key = 0x71 +marshallKeycode ForwardDeleteKey = 0x75 +marshallKeycode F4Key = 0x76 +marshallKeycode F2Key = 0x78 +marshallKeycode F1Key = 0x7A +marshallKeycode LeftArrowKey = 0x7B +marshallKeycode RightArrowKey = 0x7C +marshallKeycode DownArrowKey = 0x7D +marshallKeycode UpArrowKey = 0x7E + diff --git a/sources/Workflow/OSX/DSL.hs b/sources/Workflow/OSX/DSL.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/DSL.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RankNTypes #-} +{-# LANGUAGE TemplateHaskell, ViewPatterns #-} +-- | some higher-level workflows you can derive from the primitives in 'Workflow'. (also see the source) +module Workflow.OSX.DSL where +import Workflow.OSX.Types + +import Control.Monad.Free (MonadFree, liftF) +import Control.Monad.Free.TH (makeFree) +import qualified Data.ByteString.Char8 as BS +import Network.HTTP.Types.URI (renderQuery) + +import Data.Monoid ((<>)) + + +makeFree ''WorkflowF + +insert :: (MonadWorkflow m) => String -> m () +insert = sendText + +-- TODO +-- wait (25 ms) +-- wait $ 25 ms +-- wait (25ms) +-- +-- ms :: TimeUnit +-- instance Num (TimeUnit -> Time) +-- instance Num (UnitOf a -> a) +-- +-- module Commands.Compiler.Sugar where + +-- I want "type = mapM_ (press . KeyChord [] . key)" to be "atomic" i.e. no delay between each step. I want "press (KeyChord [Command] RKey) >> type text" to be "laggy" i.e. some delay between each step. If I "instrument" some "Workflow", by interleaving "Wait 25" between each step i.e. each "Free _", I can't distinguish between groups of steps. Thus, I should manually insert "Wait 25" between any steps that need some lag, or "automate it locally" in helper functions, but not "automate it globally" by interleaving. + +-- | access the currently selected region from Haskell, via the clipboard +copy :: (MonadWorkflow m) => m String +copy = do + sendKeyChord [CommandModifier] CKey + delay 100 -- TODO how long does it need to wait? + getClipboard + +paste :: (MonadWorkflow m) => m () +paste = do + sendKeyChord [CommandModifier] VKey + +-- | google a query. properly encodes the url. +google :: (MonadWorkflow m) => String -> m () +google (BS.pack -> query) = openURL (BS.unpack $ "https://www.google.com/search" <> renderQuery True [("q", Just query)]) + +-- TODO +-- instance convert KeyChord Workflow +-- instance convert MouseClick Workflow + +-- doubleClick :: AMonadWorkflow_ +-- doubleClick = clickMouse [] LeftButton 2 + +-- rightClick :: AMonadWorkflow_ +-- rightClick = clickMouse [] RightButton 1 + diff --git a/sources/Workflow/OSX/Example.hs b/sources/Workflow/OSX/Example.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Example.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches #-} +-- | some example workflows you can derive from the primitives in 'Workflow'. (see the source) +module Workflow.OSX.Example where +import Workflow.OSX.DSL +import Workflow.OSX.Execute +import Workflow.OSX.Types + +import Control.Monad (replicateM_) + + +main = do + attemptWorkflow testDerived + -- attemptWorkflow testChrome + +attemptWorkflow a = do + putStrLn "" + putStrLn $ showWorkflow a + runWorkflow a + +testDerived = do + _ <- copy + delay 100 + paste + +testDSL :: Workflow ClipboardText +testDSL = do + + -- delay 30 + sendKeyChord [CommandModifier, ShiftModifier] BKey + delay 1000 + sendKeyChord [CommandModifier] DownArrowKey + + app <- currentApplication + s <- getClipboard + google s + setClipboard app + getClipboard + +markWord = do + sendKeyChord [OptionModifier] LeftArrowKey + sendKeyChord [OptionModifier, ShiftModifier] RightArrowKey + +backWord = do + sendKeyChord [OptionModifier] LeftArrowKey + +forWord = do + sendKeyChord [OptionModifier] RightArrowKey + + +-- keyboard shortcuts don't need lag between each Keypress (hence +-- 'replicateM_', without 'interleave $ delay 25000'). only +-- interworkflow needs lag (e.g. a mini-buffer pop-up). +-- tested in Chrome. +testChrome :: Workflow () +testChrome = do + delay 5000 + replicateM_ 10 forWord + delay 1000 + replicateM_ 10 backWord + delay 1000 + markWord + diff --git a/sources/Workflow/OSX/Execute.hs b/sources/Workflow/OSX/Execute.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Execute.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE LambdaCase #-} +module Workflow.OSX.Execute where +import Workflow.OSX.Bindings as ObjC +import Workflow.OSX.Types + +import Control.Monad.Free +import Control.Monad.Trans.State + +import Control.Concurrent (threadDelay) + +import Data.Foldable (traverse_) +import Data.List (intercalate) +import Data.Monoid ((<>)) + + +runWorkflow :: Workflow a -> IO a +runWorkflow = iterM $ \case + -- iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a + + SendKeyChord flags key k -> ObjC.pressKey flags key >> k + SendText s k -> runWorkflow (sendTextAsKeypresses s) >> k + -- terminates because sendTextAsKeypresses is exclusively a sequence of SendKeyChord'es + + -- TODO SendMouseClick flags n button k -> ObjC.clickMouse flags n button >> k + + GetClipboard f -> ObjC.getClipboard >>= f + SetClipboard s k -> ObjC.setClipboard s >> k + + CurrentApplication f -> ObjC.currentApplication >>= f + OpenApplication app k -> ObjC.openApplication app >> k + OpenURL url k -> ObjC.openURL url >> k + + Delay t k -> threadDelay (t*1000) >> k + -- 1,000 µs is 1ms + +-- | returns a sequence of 'SendKeyChord'es. +sendTextAsKeypresses :: String -> Workflow () +sendTextAsKeypresses + = traverse_ (\(modifiers, key) -> liftF $ SendKeyChord modifiers key ()) + . concatMap char2keypress + -- liftF :: WorkflowF () -> Free WorkflowF () + +runWorkflowWithDelay :: Int -> Workflow a -> IO a +runWorkflowWithDelay t = iterM $ \case + -- iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a + + SendKeyChord flags key k -> threadDelay (t*1000) >> ObjC.pressKey flags key >> k + SendText s k -> runWorkflow (sendTextAsKeypressesWithDelay t s) >> k + + GetClipboard f -> threadDelay (t*1000) >> ObjC.getClipboard >>= f + SetClipboard s k -> threadDelay (t*1000) >> ObjC.setClipboard s >> k + + CurrentApplication f -> threadDelay (t*1000) >> ObjC.currentApplication >>= f + OpenApplication app k -> threadDelay (t*1000) >> ObjC.openApplication app >> k + OpenURL url k -> threadDelay (t*1000) >> ObjC.openURL url >> k + + Delay t_ k -> threadDelay (t_*1000) >> k + -- 1,000 µs is 1ms + +-- | returns a sequence of 'SendKeyChord'es. +sendTextAsKeypressesWithDelay :: Int -> String -> Workflow () +sendTextAsKeypressesWithDelay t + = traverse_ (\(modifiers, key) -> do + liftF $ Delay t () + liftF $ SendKeyChord modifiers key ()) + . concatMap char2keypress + -- liftF :: WorkflowF () -> Free WorkflowF () + +{- | shows the "static" data flow of some 'Workflow', by showing its primitive operations, in @do-notation@. + +e.g. + +>>> :{ +putStrLn . showWorkflow $ do + sendKeyChord [Command, Shift] BKey + delay 1000 + sendKeyChord [Command] DownArrowKey + x1 <- currentApplication + x2 <- getClipboard + openURL $ "https://www.google.com/search?q=" <> x2 + setClipboard x1 + getClipboard +:} +do + sendKeyChord ([Command,Shift]) (BKey) + delay (1000) + sendKeyChord ([Command]) (DownArrowKey) + x1 <- currentApplication + x2 <- getClipboard + openURL ("https://www.google.com/search?q={x2}") + setClipboard ("{x1}") + x3 <- getClipboard + return "{x3}" + +(note: doesn't print variables as raw strings (cf. 'print' versus 'putStrLn'), as it doesn't "crystallize" all operations into "symbols", but gives you an idea of the data flow. however, it does correctly track the control flow, even when the variables are used non-sequentially.) + +(note: the variables in the code were named to be consistent with +'gensym', for readability. but of course the bindings aren't reified, +and they could have been named anything) + +basically, the monadically-bound variable @x1@ is shown as if it were literally @"{x1}"@ (rather than, the current clipboard contents). a more complicated alternative could be to purely model the state: e.g. a clipboard, with 'SetClipboard' and 'GetClipboard' working together, etc.). + +-} +showWorkflow :: (Show x) => Workflow x -> String +showWorkflow as = "do\n" <> evalState (showWorkflow_ as) 1 + + where + showWorkflow_ :: (Show x) => Workflow x -> State Gensym String + showWorkflow_ (Pure x) = return $ " return " <> show x <> "\n" + showWorkflow_ (Free a) = showWorkflowF a + + showWorkflowF :: (Show x) => WorkflowF (Workflow x) -> State Gensym String + showWorkflowF = \case + SendKeyChord flags key k -> ((" sendKeyChord " <> showArgs [show flags, show key]) <>) <$> showWorkflow_ k + -- TODO SendMouseClick flags n b k -> ((" sendMouseClick " <> showArgs [show flags, show n, show b]) <>) <$> showWorkflow_ k + SendText s k -> ((" sendText " <> showArgs [show s]) <>) <$> showWorkflow_ k + + SetClipboard s k -> ((" setClipboard " <> showArgs [show s]) <>) <$> showWorkflow_ k + OpenApplication app k -> ((" openApplication " <> showArgs [show app]) <>) <$> showWorkflow_ k + OpenURL url k -> ((" openURL " <> showArgs [show url]) <>) <$> showWorkflow_ k + Delay t k -> ((" delay " <> showArgs [show t]) <>) <$> showWorkflow_ k + + -- TODO distinguish between strings and variables to avoid: + -- x2 <- getClipboard + -- sendText ("x2") + + GetClipboard f -> do + x <- gensym + rest <- showWorkflow_ (f ("{"<>x<>"}")) + return $ " " <> x <> " <- getClipboard" <> showArgs [] <> rest + + CurrentApplication f -> do + x <- gensym + rest <- showWorkflow_ (f ("{"<>x<>"}")) + return $ " " <> x <> " <- currentApplication" <> showArgs [] <> rest + + showArgs :: [String] -> String + showArgs xs = intercalate " " (fmap (("(" <>) . (<> ")")) xs) <> "\n" + +type Gensym = Int + +gensym :: State Gensym String +gensym = do + i <- get + put $ i + 1 + return $ "x" <> show i + diff --git a/sources/Workflow/OSX/Extra.hs b/sources/Workflow/OSX/Extra.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Extra.hs @@ -0,0 +1,20 @@ +-- | assorted functionality, imported by most modules in this package. +module Workflow.OSX.Extra + ( module Workflow.OSX.Extra + , module Data.Data + , module GHC.Generics + , (<>) + , traverse_ + ) where + +import Control.Monad.Catch (MonadThrow, throwM) + +import Data.Data (Data) +import GHC.Generics (Generic) +import Data.Foldable (traverse_) +import Data.Monoid ((<>)) + + +failed :: (MonadThrow m) => String -> m a +failed = throwM . userError + diff --git a/sources/Workflow/OSX/Marshall.hs b/sources/Workflow/OSX/Marshall.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Marshall.hs @@ -0,0 +1,62 @@ +module Workflow.OSX.Marshall where +import Workflow.OSX.Constants +import Workflow.OSX.Types + +import Data.BitVector hiding (foldl) + +import Foreign.C.Types + + +{- | Marshall the bitmask. + +relates Haskell types with Objective-C types: + +* Haskell list-of-enum ~ Objective-C bit-mask +* Haskell @['Modifier']@ ~ Objective-C @CGEventFlags@ +* Haskell 'CULLong' ~ Objective-C @uint64_t@ +* Haskell can marshal 'CULLong' + + += Implementation + +"Bit-vectors are interpreted as unsigned integers (i.e. natural numbers)" + +the folded bitvector size, is the initial bitvector size. because: + +>>> toBits (zeros 5 .|. ones 2) +[False, False, False, True, True] + +and: + +>>> foldl (+) 0 [1,2,3] +((0 + 1) + 2) + 3 + +since each bit'mask' is disjoint, and we logical-OR the bits +together, we don't need to remove duplicates. + + +-} +encodeModifiers :: [Modifier] -> CULLong +encodeModifiers + = CULLong + . fromIntegral + . uint + . foldl (.|.) (zeros 64) + . fmap marshallMask + +{- | marshall the 'keycode' + +relates Haskell types with Objective-C types: + +* Haskell 'VirtualKey' ~ Objective-C @CGKeyCode@ +* Haskell 'CUShort' ~ Objective-C @uint16_t@ +* Haskell can marshal 'CUShort' + +-} +encodeKey :: Key -> CUShort +encodeKey + = CUShort + . fromIntegral + . uint + . marshallKeycode + diff --git a/sources/Workflow/OSX/Types.hs b/sources/Workflow/OSX/Types.hs new file mode 100644 --- /dev/null +++ b/sources/Workflow/OSX/Types.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, PatternSynonyms, ConstraintKinds, FlexibleContexts #-} +module Workflow.OSX.Types where +import Workflow.OSX.Extra + +import Control.Monad.Free (MonadFree, Free) +import Control.Monad.Catch (MonadThrow) +import Foreign.C.Types + + + +-- | a monad constraint for "workflow effects", (just like @MonadState@ is a monad constraint for "state effects") can use in any monad transformer stack that handles them. +type MonadWorkflow = MonadFree WorkflowF + +-- {- | for convenience. +-- without loss of generality (I don't think) when declaring simple monadic effects (like Kleisli arrows). + +-- e.g. + +-- @ +-- getClipboard :: 'AMonadWorkflow' String -- generalized +-- getClipboard :: ('MonadWorkflow' m) => m String -- generalized +-- getClipboard :: Free 'WorkflowF' String -- specialized +-- @ + +-- -} +-- type AMonadWorkflow a = forall m. (MonadWorkflow m) => m a + +-- type AMonadWorkflow_ = forall m. (MonadWorkflow m) => m () + +-- | a platform-agnostic free monad, which can be executed by platform-specific bindings. +type Workflow = Free WorkflowF + +type Workflow_ = Workflow () + +-- | the "Workflow Functor". +data WorkflowF k + = SendKeyChord [Modifier] Key k + | SendText String k -- ^ a logical grouping for debugging and optimizing + + | GetClipboard (ClipboardText -> k) + | SetClipboard ClipboardText k + + | CurrentApplication (Application -> k) + | OpenApplication Application k + + --TODO | SendMouseClick [Modifier] Int MouseButton k + --TODO | CurrentWindow (Window -> k) + --TODO | OpenWindow Window k + + | OpenURL URL k + + | Delay Time k + -- TODO | Annihilate SomeException -- no k, it annihilates the action, for mzero and MonadThrow + -- TODO | PerformIO (IO a) (a -> k) + deriving (Functor) + -- deriving (Functor,Data) + +-- data WorkflowF mod key k TODO platform-specific keyboards +-- = SendKeyChord [mod] key k +-- TODO convert between keyboards, like Alt on Windows/Linux being Command on OSX + +type ClipboardText = String +-- newtype ClipboardText = ClipboardText String deriving (Show,Eq,Ord,IsString) + +type Application = String +-- newtype Application = Application String deriving (Show,Eq,Ord,IsString) + +type URL = String +-- newtype URL = URL String deriving (Show,Eq,Ord,IsString) + +type Time = Int +-- newtype Time = Time String deriving (Show,Eq,Ord,Num) +-- units package + +-- class IsString TODO needs Free WorkflowF, which must be lifted, which isn't better than insert + + +{- | relates a Haskell type with a Objective-C type: + +* Objective-C defines @typedef unsigned short uint16_t;@ +* line 34 of defines @typedef uint16_t CGKeyCode;@ + +-} +type CGKeyCode = CUShort + +{- | relates a Haskell type with a Objective-C type: + +* Objective-C defines @typedef unsigned long long uint64_t;@ +* line 98 of defines @typedef uint64_t CGEventFlags;@ + +-} +type CGEventFlags = CULLong + +-- {- | relates a Haskell type with a Objective-C type: + + +-- -} +-- type CGEventType = + +-- {- | relates a Haskell type with a Objective-C type: + + +-- -} +-- type CGMouseButton = + + +-- data MouseClick = MouseClick [Modifier] Positive MouseButton +-- deriving (Show,Eq,Ord) + +-- data MouseButton = LeftButton | MiddleButton | RightButton +-- deriving (Show,Eq,Ord,Enum,Bounded) + +-- data KeyChord = KeyChord [Modifier] Key +-- deriving (Show,Eq,Ord) + +-- | an (unordered, no-duplicates) sequence of key chords make up a keyboard shortcut +type KeyRiff = [KeyChord] + +-- | +type KeyChord = ([Modifier], Key) + +-- | @pattern KeyChord ms k = (ms,k)@ +pattern KeyChord ms k = (ms, k) + +-- | @pattern NoMod k = ([],k)@ +pattern NoMod k = ([], k) + +-- | appends a modifier +addMod :: Modifier -> KeyChord -> KeyChord +addMod m (ms, k) = KeyChord (m:ms) k +-- false positive nonexhaustive warning with the KeyChord pattern + +{- | modifier keys are keys that can be "held". + +the escape key is "pressed", not "held", it seems. +(possibly explains its behavior in your terminal emulator?) + +@alt@ is 'OptionModifier'. + +-} +data Modifier = ControlModifier | CommandModifier | ShiftModifier | OptionModifier | FunctionModifier + -- Command is qualified to not conflict with Commands.Command.Types + deriving (Show,Eq,Ord,Bounded,Enum,Data,Generic) +-- data Modifier = ControlMod | CommandMod | ShiftMod | OptionMod | FunctionMod + +{- | all the keys on a standard Apple keyboard. + + +-} +data Key + + = CommandKey + | ControlKey + | CapsLockKey + | ShiftKey + | OptionKey + | FunctionKey + + | GraveKey + | MinusKey + | EqualKey + | DeleteKey + | ForwardDeleteKey + | LeftBracketKey + | RightBracketKey + | BackslashKey + | SemicolonKey + | QuoteKey + | CommaKey + | PeriodKey + | SlashKey + + | TabKey + | SpaceKey + | ReturnKey + + | LeftArrowKey + | RightArrowKey + | DownArrowKey + | UpArrowKey + + | AKey + | BKey + | CKey + | DKey + | EKey + | FKey + | GKey + | HKey + | IKey + | JKey + | KKey + | LKey + | MKey + | NKey + | OKey + | PKey + | QKey + | RKey + | SKey + | TKey + | UKey + | VKey + | WKey + | XKey + | YKey + | ZKey + + | ZeroKey + | OneKey + | TwoKey + | ThreeKey + | FourKey + | FiveKey + | SixKey + | SevenKey + | EightKey + | NineKey + + | EscapeKey + | F1Key + | F2Key + | F3Key + | F4Key + | F5Key + | F6Key + | F7Key + | F8Key + | F9Key + | F10Key + | F11Key + | F12Key + | F13Key + | F14Key + | F15Key + | F16Key + | F17Key + | F18Key + | F19Key + | F20Key + + deriving (Show,Eq,Ord,Bounded,Enum,Data,Generic) + +{- | + +>>> int2keypress -12 +[([],MinusKey),([],OneKey),([],TwoKey)] + + +-} +int2keypress :: Integer -> [KeyChord] +int2keypress = concatMap char2keypress . show + +{- | + +a (base ten) digit is a number between zero and nine inclusive. + +>>> digit2keypress 2 +([],TwoKey) + +>>> digit2keypress -2 +Nothing + +>>> digit2keypress 12 +Nothing + +-} +digit2keypress :: (MonadThrow m) => Integer -> m KeyChord +digit2keypress 0 = return $ NoMod ZeroKey +digit2keypress 1 = return $ NoMod OneKey +digit2keypress 2 = return $ NoMod TwoKey +digit2keypress 3 = return $ NoMod ThreeKey +digit2keypress 4 = return $ NoMod FourKey +digit2keypress 5 = return $ NoMod FiveKey +digit2keypress 6 = return $ NoMod SixKey +digit2keypress 7 = return $ NoMod SevenKey +digit2keypress 8 = return $ NoMod EightKey +digit2keypress 9 = return $ NoMod NineKey + +digit2keypress k = failed $ "digit2keypress: digits must be between zero and nine: " <> show k + + +{- | the keypress that would insert the character into the application. + +>>> char2keypress '@' :: Maybe KeyChord +Just ([ShiftModifier], TwoKey) + +some characters cannot be represented as keypresses, like some non-printable characters +(in arbitrary applications, not just the terminal emulator): + +>>> char2keypress '\0' :: Maybe KeyChord +Nothing + +prop> case char2keypress c of { Just ([],_) -> True; Just ([ShiftModifier],_) -> True; Nothing -> True; _ -> False } + +-} +char2keypress :: (MonadThrow m) => Char -> m KeyChord -- ((,) [Modifier] Key) + +char2keypress 'a' = return $ (,) [ ] AKey +char2keypress 'A' = return $ (,) [ShiftModifier] AKey +char2keypress 'b' = return $ (,) [ ] BKey +char2keypress 'B' = return $ (,) [ShiftModifier] BKey +char2keypress 'c' = return $ (,) [ ] CKey +char2keypress 'C' = return $ (,) [ShiftModifier] CKey +char2keypress 'd' = return $ (,) [ ] DKey +char2keypress 'D' = return $ (,) [ShiftModifier] DKey +char2keypress 'e' = return $ (,) [ ] EKey +char2keypress 'E' = return $ (,) [ShiftModifier] EKey +char2keypress 'f' = return $ (,) [ ] FKey +char2keypress 'F' = return $ (,) [ShiftModifier] FKey +char2keypress 'g' = return $ (,) [ ] GKey +char2keypress 'G' = return $ (,) [ShiftModifier] GKey +char2keypress 'h' = return $ (,) [ ] HKey +char2keypress 'H' = return $ (,) [ShiftModifier] HKey +char2keypress 'i' = return $ (,) [ ] IKey +char2keypress 'I' = return $ (,) [ShiftModifier] IKey +char2keypress 'j' = return $ (,) [ ] JKey +char2keypress 'J' = return $ (,) [ShiftModifier] JKey +char2keypress 'k' = return $ (,) [ ] KKey +char2keypress 'K' = return $ (,) [ShiftModifier] KKey +char2keypress 'l' = return $ (,) [ ] LKey +char2keypress 'L' = return $ (,) [ShiftModifier] LKey +char2keypress 'm' = return $ (,) [ ] MKey +char2keypress 'M' = return $ (,) [ShiftModifier] MKey +char2keypress 'n' = return $ (,) [ ] NKey +char2keypress 'N' = return $ (,) [ShiftModifier] NKey +char2keypress 'o' = return $ (,) [ ] OKey +char2keypress 'O' = return $ (,) [ShiftModifier] OKey +char2keypress 'p' = return $ (,) [ ] PKey +char2keypress 'P' = return $ (,) [ShiftModifier] PKey +char2keypress 'q' = return $ (,) [ ] QKey +char2keypress 'Q' = return $ (,) [ShiftModifier] QKey +char2keypress 'r' = return $ (,) [ ] RKey +char2keypress 'R' = return $ (,) [ShiftModifier] RKey +char2keypress 's' = return $ (,) [ ] SKey +char2keypress 'S' = return $ (,) [ShiftModifier] SKey +char2keypress 't' = return $ (,) [ ] TKey +char2keypress 'T' = return $ (,) [ShiftModifier] TKey +char2keypress 'u' = return $ (,) [ ] UKey +char2keypress 'U' = return $ (,) [ShiftModifier] UKey +char2keypress 'v' = return $ (,) [ ] VKey +char2keypress 'V' = return $ (,) [ShiftModifier] VKey +char2keypress 'w' = return $ (,) [ ] WKey +char2keypress 'W' = return $ (,) [ShiftModifier] WKey +char2keypress 'x' = return $ (,) [ ] XKey +char2keypress 'X' = return $ (,) [ShiftModifier] XKey +char2keypress 'y' = return $ (,) [ ] YKey +char2keypress 'Y' = return $ (,) [ShiftModifier] YKey +char2keypress 'z' = return $ (,) [ ] ZKey +char2keypress 'Z' = return $ (,) [ShiftModifier] ZKey + +char2keypress '0' = return $ (,) [ ] ZeroKey +char2keypress ')' = return $ (,) [ShiftModifier] ZeroKey +char2keypress '1' = return $ (,) [ ] OneKey +char2keypress '!' = return $ (,) [ShiftModifier] OneKey +char2keypress '2' = return $ (,) [ ] TwoKey +char2keypress '@' = return $ (,) [ShiftModifier] TwoKey +char2keypress '3' = return $ (,) [ ] ThreeKey +char2keypress '#' = return $ (,) [ShiftModifier] ThreeKey +char2keypress '4' = return $ (,) [ ] FourKey +char2keypress '$' = return $ (,) [ShiftModifier] FourKey +char2keypress '5' = return $ (,) [ ] FiveKey +char2keypress '%' = return $ (,) [ShiftModifier] FiveKey +char2keypress '6' = return $ (,) [ ] SixKey +char2keypress '^' = return $ (,) [ShiftModifier] SixKey +char2keypress '7' = return $ (,) [ ] SevenKey +char2keypress '&' = return $ (,) [ShiftModifier] SevenKey +char2keypress '8' = return $ (,) [ ] EightKey +char2keypress '*' = return $ (,) [ShiftModifier] EightKey +char2keypress '9' = return $ (,) [ ] NineKey +char2keypress '(' = return $ (,) [ShiftModifier] NineKey + +char2keypress '`' = return $ (,) [ ] GraveKey +char2keypress '~' = return $ (,) [ShiftModifier] GraveKey +char2keypress '-' = return $ (,) [ ] MinusKey +char2keypress '_' = return $ (,) [ShiftModifier] MinusKey +char2keypress '=' = return $ (,) [ ] EqualKey +char2keypress '+' = return $ (,) [ShiftModifier] EqualKey +char2keypress '[' = return $ (,) [ ] LeftBracketKey +char2keypress '{' = return $ (,) [ShiftModifier] LeftBracketKey +char2keypress ']' = return $ (,) [ ] RightBracketKey +char2keypress '}' = return $ (,) [ShiftModifier] RightBracketKey +char2keypress '\\' = return $ (,) [ ] BackslashKey +char2keypress '|' = return $ (,) [ShiftModifier] BackslashKey +char2keypress ';' = return $ (,) [ ] SemicolonKey +char2keypress ':' = return $ (,) [ShiftModifier] SemicolonKey +char2keypress '\'' = return $ (,) [ ] QuoteKey +char2keypress '"' = return $ (,) [ShiftModifier] QuoteKey +char2keypress ',' = return $ (,) [ ] CommaKey +char2keypress '<' = return $ (,) [ShiftModifier] CommaKey +char2keypress '.' = return $ (,) [ ] PeriodKey +char2keypress '>' = return $ (,) [ShiftModifier] PeriodKey +char2keypress '/' = return $ (,) [ ] SlashKey +char2keypress '?' = return $ (,) [ShiftModifier] SlashKey + +char2keypress ' ' = return $ (,) [ ] SpaceKey +char2keypress '\t' = return $ (,) [ ] TabKey +char2keypress '\n' = return $ (,) [ ] ReturnKey + +char2keypress c = failed $ "char2keypress: un-pressable Char: " <> show c + + +{- | the character that represents the keypress: + +>>> keypress2char ([ShiftModifier], TwoKey) :: Maybe Char +Just '@' + +some keypresses cannot be represented as characters, like keyboard shortcuts: + +>>> keypress2char ([Command], CKey) :: Maybe Char +Nothing + +>>> import Data.Char +>>> import Data.Maybe +prop> maybe True isAscii (keypress2char k) +TODO replace true with redo test + +-} +keypress2char :: (MonadThrow m) => KeyChord -> m Char -- ((,) [Modifier] Key) + +keypress2char ((,) [ ] AKey) = return $ 'a' +keypress2char ((,) [ShiftModifier] AKey) = return $ 'A' +keypress2char ((,) [ ] BKey) = return $ 'b' +keypress2char ((,) [ShiftModifier] BKey) = return $ 'B' +keypress2char ((,) [ ] CKey) = return $ 'c' +keypress2char ((,) [ShiftModifier] CKey) = return $ 'C' +keypress2char ((,) [ ] DKey) = return $ 'd' +keypress2char ((,) [ShiftModifier] DKey) = return $ 'D' +keypress2char ((,) [ ] EKey) = return $ 'e' +keypress2char ((,) [ShiftModifier] EKey) = return $ 'E' +keypress2char ((,) [ ] FKey) = return $ 'f' +keypress2char ((,) [ShiftModifier] FKey) = return $ 'F' +keypress2char ((,) [ ] GKey) = return $ 'g' +keypress2char ((,) [ShiftModifier] GKey) = return $ 'G' +keypress2char ((,) [ ] HKey) = return $ 'h' +keypress2char ((,) [ShiftModifier] HKey) = return $ 'H' +keypress2char ((,) [ ] IKey) = return $ 'i' +keypress2char ((,) [ShiftModifier] IKey) = return $ 'I' +keypress2char ((,) [ ] JKey) = return $ 'j' +keypress2char ((,) [ShiftModifier] JKey) = return $ 'J' +keypress2char ((,) [ ] KKey) = return $ 'k' +keypress2char ((,) [ShiftModifier] KKey) = return $ 'K' +keypress2char ((,) [ ] LKey) = return $ 'l' +keypress2char ((,) [ShiftModifier] LKey) = return $ 'L' +keypress2char ((,) [ ] MKey) = return $ 'm' +keypress2char ((,) [ShiftModifier] MKey) = return $ 'M' +keypress2char ((,) [ ] NKey) = return $ 'n' +keypress2char ((,) [ShiftModifier] NKey) = return $ 'N' +keypress2char ((,) [ ] OKey) = return $ 'o' +keypress2char ((,) [ShiftModifier] OKey) = return $ 'O' +keypress2char ((,) [ ] PKey) = return $ 'p' +keypress2char ((,) [ShiftModifier] PKey) = return $ 'P' +keypress2char ((,) [ ] QKey) = return $ 'q' +keypress2char ((,) [ShiftModifier] QKey) = return $ 'Q' +keypress2char ((,) [ ] RKey) = return $ 'r' +keypress2char ((,) [ShiftModifier] RKey) = return $ 'R' +keypress2char ((,) [ ] SKey) = return $ 's' +keypress2char ((,) [ShiftModifier] SKey) = return $ 'S' +keypress2char ((,) [ ] TKey) = return $ 't' +keypress2char ((,) [ShiftModifier] TKey) = return $ 'T' +keypress2char ((,) [ ] UKey) = return $ 'u' +keypress2char ((,) [ShiftModifier] UKey) = return $ 'U' +keypress2char ((,) [ ] VKey) = return $ 'v' +keypress2char ((,) [ShiftModifier] VKey) = return $ 'V' +keypress2char ((,) [ ] WKey) = return $ 'w' +keypress2char ((,) [ShiftModifier] WKey) = return $ 'W' +keypress2char ((,) [ ] XKey) = return $ 'x' +keypress2char ((,) [ShiftModifier] XKey) = return $ 'X' +keypress2char ((,) [ ] YKey) = return $ 'y' +keypress2char ((,) [ShiftModifier] YKey) = return $ 'Y' +keypress2char ((,) [ ] ZKey) = return $ 'z' +keypress2char ((,) [ShiftModifier] ZKey) = return $ 'Z' + +keypress2char ((,) [ ] ZeroKey) = return $ '0' +keypress2char ((,) [ShiftModifier] ZeroKey) = return $ ')' +keypress2char ((,) [ ] OneKey) = return $ '1' +keypress2char ((,) [ShiftModifier] OneKey) = return $ '!' +keypress2char ((,) [ ] TwoKey) = return $ '2' +keypress2char ((,) [ShiftModifier] TwoKey) = return $ '@' +keypress2char ((,) [ ] ThreeKey) = return $ '3' +keypress2char ((,) [ShiftModifier] ThreeKey) = return $ '#' +keypress2char ((,) [ ] FourKey) = return $ '4' +keypress2char ((,) [ShiftModifier] FourKey) = return $ '$' +keypress2char ((,) [ ] FiveKey) = return $ '5' +keypress2char ((,) [ShiftModifier] FiveKey) = return $ '%' +keypress2char ((,) [ ] SixKey) = return $ '6' +keypress2char ((,) [ShiftModifier] SixKey) = return $ '^' +keypress2char ((,) [ ] SevenKey) = return $ '7' +keypress2char ((,) [ShiftModifier] SevenKey) = return $ '&' +keypress2char ((,) [ ] EightKey) = return $ '8' +keypress2char ((,) [ShiftModifier] EightKey) = return $ '*' +keypress2char ((,) [ ] NineKey) = return $ '9' +keypress2char ((,) [ShiftModifier] NineKey) = return $ '(' + +keypress2char ((,) [ ] GraveKey) = return $ '`' +keypress2char ((,) [ShiftModifier] GraveKey) = return $ '~' +keypress2char ((,) [ ] MinusKey) = return $ '-' +keypress2char ((,) [ShiftModifier] MinusKey) = return $ '_' +keypress2char ((,) [ ] EqualKey) = return $ '=' +keypress2char ((,) [ShiftModifier] EqualKey) = return $ '+' +keypress2char ((,) [ ] LeftBracketKey) = return $ '[' +keypress2char ((,) [ShiftModifier] LeftBracketKey) = return $ '{' +keypress2char ((,) [ ] RightBracketKey) = return $ ']' +keypress2char ((,) [ShiftModifier] RightBracketKey) = return $ '}' +keypress2char ((,) [ ] BackslashKey) = return $ '\\' +keypress2char ((,) [ShiftModifier] BackslashKey) = return $ '|' +keypress2char ((,) [ ] SemicolonKey) = return $ ';' +keypress2char ((,) [ShiftModifier] SemicolonKey) = return $ ':' +keypress2char ((,) [ ] QuoteKey) = return $ '\'' +keypress2char ((,) [ShiftModifier] QuoteKey) = return $ '"' +keypress2char ((,) [ ] CommaKey) = return $ ',' +keypress2char ((,) [ShiftModifier] CommaKey) = return $ '<' +keypress2char ((,) [ ] PeriodKey) = return $ '.' +keypress2char ((,) [ShiftModifier] PeriodKey) = return $ '>' +keypress2char ((,) [ ] SlashKey) = return $ '/' +keypress2char ((,) [ShiftModifier] SlashKey) = return $ '?' + +keypress2char ((,) [ ] SpaceKey) = return $ ' ' +keypress2char ((,) [ ] TabKey) = return $ '\t' +keypress2char ((,) [ ] ReturnKey) = return $ '\n' + +keypress2char k = failed $ "keypress2char: non-unicode-representable Keypress: " <> show k + +-- TODO partial isomorphism between char2keypress and keypress2char? diff --git a/workflow-osx.cabal b/workflow-osx.cabal new file mode 100644 --- /dev/null +++ b/workflow-osx.cabal @@ -0,0 +1,93 @@ +name: workflow-osx +version: 0.0.0 +cabal-version: >=1.10 +build-type: Simple +license: GPL-3 +license-file: LICENSE +copyright: Copyright (C) 2015 Spiros M. Boosalis +maintainer: samboosalis@gmail.com +stability: experimental +homepage: https://github.com/sboosali/workflow-osx#readme +bug-reports: https://github.com/sboosali/workflow-osx/issues +synopsis: a "Desktop Workflow" monad with Objective-C bindings +description: + a \"Desktop Workflow\" monad with Objective-C bindings + . + e.g. press some keys, click the mouse, get/set the clipboard + . + see @Workflow.OSX@ for several examples + . + (if the build fails, see the ) + . + (this package is on hackage for convenience, but it's still a prerelease) + +category: Accessibility, Apple, Automation, Bindings, Desktop, FFI +author: Spiros Boosalis +tested-with: GHC ==7.10.1 +extra-source-files: + README.md + cbits/objc_workflow.h + cbits/Makefile + +source-repository head + type: git + location: https://github.com/sboosali/workflow-osx + +library + + if !os(osx) + buildable: False + + exposed-modules: + Workflow.OSX + Workflow.OSX.Example + Workflow.OSX.Types + Workflow.OSX.Bindings + Workflow.OSX.Bindings.Raw + Workflow.OSX.Constants + Workflow.OSX.Marshall + Workflow.OSX.Execute + Workflow.OSX.DSL + Workflow.OSX.Extra + + build-depends: + http-types ==0.8.*, + bv ==0.3.*, + free ==4.12.*, + filepath ==1.4.*, + exceptions ==0.8.*, + +-- time -any, + + mtl ==2.2.*, + transformers ==0.4.2.*, + bytestring ==0.10.*, + + base ==4.8.* + + default-language: Haskell2010 + hs-source-dirs: sources + ghc-options: -Wall + default-extensions: AutoDeriveTypeable + +-- the functionality I needed was found only in some deprecated APIs + cc-options: -Wno-deprecated-declarations + ld-options: -ObjC + frameworks: Cocoa + c-sources: + cbits/objc_workflow.m + includes: + cbits/objc_workflow.h + install-includes: + cbits/objc_workflow.h + include-dirs: cbits + +executable example + main-is: Main.hs + build-depends: + workflow-osx ==0.0.0, + base ==4.8.* + default-language: Haskell2010 + hs-source-dirs: . + ghc-options: -Wall +