diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for spartacon + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,11 @@ +Copyright 2021 Daniel Wagner + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,57 @@ +**spartacon** is a Unix-style global hotkey daemon. It embraces the philosophies of "do one thing, and do it well" and "text in, text out". It allows you to capture hotkeys on X11, without having any strong opinions about what actions should happen when those keys are pressed. + +There are other hotkey applications out there; for example, modern desktop environments typically have a way to bind keys to actions, and there are standalone apps like [HyperKeys](https://hyperkeys.xureilab.com/). Typically, these implementations assume that the thing you want to happen when a key is hit is to launch a process. If what you really want is to just add hotkey functionality to an existing application without it needing to know how to do that, those are typically not suitable, because the tool being controlled is already running. + +spartacon sits in that space: when you want to control a "text in, text out"-style program with hotkeys, this is the tool for you. (And if you decide to pipe spartacon to something that launches processes, that's no skin off my teeth!) + +# Installation + +0. Install GHC and cabal in your favorite way. [ghcup](https://www.haskell.org/ghcup/) is nice, or most package managers have them. +1. Install the development variants of your X11 libraries; it probably makes the most sense to do this through your package manager. The names of the packages that provide these vary a lot from distribution to distribution. If you don't install anything, the build process below will output some text about which library is missing that may help you search your package manager. +2. Clone the repo. `git clone https://github.com/dmwit/spartacon && cd spartacon` +3. Build and install. `cabal install` +4. If this is your first time using `cabal`, you will likely need to add its output directory to your `PATH`. + +# Usage + +spartacon accepts text on standard input in the [`config-value`](http://hackage.haskell.org/package/config-value/docs/Config.html) format. A simple example looks like this: + + ignore: [NL, M5] + bindings: + C-A-y: "foo" + F11: quit + +The `ignore` field is modifiers that you want to be "ignored" -- that is, where you want your keybindings to fire whether those modifiers are on or not. It's optional, and the default is `[NL]` for numlock (see table below for other choices). So, for example, in the above file, spartacon will print out the string `foo` for any of the keypresses `C-A-y`, `NL-C-A-y`, `M5-C-A-y`, or `NL-M5-C-A-y`. The `ignore` field is never required to get a desired reaction from spartacon; it is only shorthand for binding many modifier variants at a time. + +The `bindings` field is a collection (possibly empty) of bindings and actions. It's optional, and the default has no bindings or actions. Each binding has a modifier part and a key part. + +The modifier part is a sequence (possibly empty), where each element of the sequence is one of the following strings followed by a `-`: + + | string | meaning | + |--------|---------------------------------------------| + | S | shift | + | L | lock (usually capslock) | + | C | control | + | A | alt (=mod1) | + | M1 | mod1 (usually alt) | + | NL | numlock (=mod2) | + | M2 | mod2 (usually numlock) | + | M3 | mod3 | + | M4 | mod4 (usually the Windows key or similar) | + | M5 | mod5 | + | B | no (additional) modifier; see next sentence | + +The `B-` prefix is required for unmodified keycodes and unmodified keysyms that do not start with a letter because `config-value` atoms must start with a letter. + +You may also use lower case, but the case must be consistent within each string (e.g. `nL` is not allowed). Only the presence or absence of one of these strings matters; if there are multiple appearances, all but the first are ignored. For example, `C-S-`, `C-S-C-`, `c-S-`, and `c-b-s-b-C-B-S-` all mean the same thing: for this keybinding to fire, both control and shift (and nothing else) must be held down. + +The key part of a binding may be either a keysym or a keycode. Keysyms are exactly those accepted by `XStringToKeysym`; you can find out exactly how to spell a keysym name with `xev` or similar. Keycodes are smallish numbers (no larger than 255); to distinguish these from keysyms, you must prepend a `.` to the number. + +For those among you not intimately familiar with X11 terminology, the distinction between keysym and keycode is that a keysym is the logical interpretation of a key while a keycode is the physical location of a key. For example, `y` means that to fire this keybinding, you must press the `y` key, wherever that may be in the current layout -- just to the right of T in the QWERTY layout but just to the right of P in the Dvorak layout. In some layouts, a single keysym may be available from multiple physical keys; spartacon will correctly respond to any of the physical keys for that keysym. On my computer, in the QWERTY layout, Y is associated with keycode 29, so as a second example, `.29` means the sixth letter key from the left in the top row, no matter what letter that's actually associated with in the current layout -- Y in the QWERTY layout, F in the Dvorak layout, etc. If you request a binding with a keysym, then change layout, spartacon will modify its hotkey definitions appropriately. + +It is possible to accidentally request multiple actions for the same key; for example, by requesting a keysym and a keycode that both correspond to the same key, or by requesting the "upper-case" and "lower-case" keysym variants associated with a single key. In this case, spartacon will print a short warning message to stderr and choose one of the proposed actions arbitrarily. A short warning will also be printed to stderr if a requested keysym is not associated with any key in the current layout. + +An action is one of the following things: +* The literal atom `quit`. This instructs spartacon to successfully exit. +* The literal atom `exit`. Ditto. +* An arbitrary string. This instructs spartacon to print that string to stdout. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Data.Bits +import Data.Either.Validation +import Data.Foldable +import Data.Functor.Identity +import Data.List +import Data.Map (Map) +import Data.Maybe +import Data.Relation (Relation) +import Data.Set (Set) +import Data.Text (Text) +import Data.Traversable +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras +import System.Exit +import System.IO +import Text.Printf + +import qualified Config as C +import qualified Config.Schema as C +import qualified Data.Map as M +import qualified Data.Relation as R +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.IO as T + +main :: IO () +main = do + config <- readConfiguration + runSpartacon config $ do + root <- askRoot + refreshBindings + x selectInput root keyPressMask + suspend $ \ctx s -> allocaXEvent $ \evPtr -> resume ctx s . forever $ do + x nextEvent evPtr + ev <- io getEvent evPtr + case ev of + MappingNotifyEvent{} -> do + io refreshKeyboardMapping ev + km <- x reloadKeymap + modify (\s -> s { keymap = km }) + refreshBindings + KeyEvent{} + | ev_event_type ev /= keyPress -> pure () + | otherwise -> do + bs <- gets bindings + io $ case M.lookup (ev_state ev, ev_keycode ev) bs of + Just Quit -> exitWith ExitSuccess + Just (Print t) -> T.putStr t >> hFlush stdout + Nothing -> hPrintf stderr "WARNING: got key event with no corresponding binding: %s\n" (show ev) + _ -> io hPrintf stderr "WARNING: ignoring unexpected X event %s\n" (show ev) + +readConfiguration :: IO Configuration +readConfiguration = do + t <- T.getContents + v <- case C.parse t of + Left err -> do + hPrintf + stderr + "Formatting error in configuration. Check the syntax reference at:\nhttp://hackage.haskell.org/package/config-value/docs/Config.html\n\t%s\n" + (displayException err) + exitWith (ExitFailure 1) + Right v -> pure v + case C.loadValue C.anySpec v of + Left err -> hPutStrLn stderr (displayException err) >> exitWith (ExitFailure 2) + Right config -> pure config + +data Configuration = Configuration + { ignoreMasks :: [KeyMask] + , bindingRequests :: [(BindingRequest, Action)] + } deriving (Eq, Ord, Read, Show) + +data BindingRequest = BindingRequest + { modifier :: KeyMask + , key :: Either KeySym KeyCode + } deriving (Eq, Ord, Read, Show) + +data Action = Quit | Print Text + deriving (Eq, Ord, Read, Show) + +data Context = Context + { configuration :: Configuration + , display :: Display + } deriving (Eq, Ord, Show) + +data KeyboardState = KeyboardState + { keymap :: Relation KeyCode KeySym + , bindings :: Map (KeyMask, KeyCode) Action + } deriving (Eq, Ord, Show) + +type Spartacon = ReaderT Context (StateT KeyboardState IO) + +runSpartacon :: Configuration -> Spartacon a -> IO a +runSpartacon config act = do + dpy <- openDisplay "" + keys <- reloadKeymap dpy + evalStateT (runReaderT act (Context config dpy)) (KeyboardState keys M.empty) + +suspend :: (Context -> KeyboardState -> IO (a, KeyboardState)) -> Spartacon a +suspend f = ReaderT $ StateT . f + +resume :: Context -> KeyboardState -> Spartacon a -> IO (a, KeyboardState) +resume ctx s act = runStateT (runReaderT act ctx) s + +reloadKeymap :: Display -> IO (Relation KeyCode KeySym) +reloadKeymap dpy = do + mapping <- for [lo..hi] $ \keycode -> + for [0..3] $ \i -> + (,) keycode <$> keycodeToKeysym dpy keycode i + pure . R.fromList $ + [ (keycode, keysym) + | pairs <- mapping + , (keycode, keysym) <- pairs + , keysym /= noSymbol + ] + where + (lo_, hi_) = displayKeycodes dpy + [lo, hi] = map fromIntegral [lo_, hi_] + +expandCodes :: + Configuration -> + Relation KeyCode KeySym -> + [((BindingRequest, Action), (KeyMask, KeyCode))] +expandCodes conf mapping = + [ (reqAct, (modifier req .|. extraMask, code)) + | extraMasks <- subsequences (ignoreMasks conf) + , let extraMask = foldl' (.|.) 0 extraMasks + , reqAct@(req, act) <- bindingRequests conf + , code <- case key req of + Right code -> [code] + Left sym -> S.toList . R.lookupRan sym $ mapping + ] + +checkCodes :: + [(BindingRequest, Action)] -> + [((BindingRequest, Action), (KeyMask, KeyCode))] -> + ( [(BindingRequest, Action)] + , Map (KeyMask, KeyCode) (Set (BindingRequest, Action)) + , Map (KeyMask, KeyCode) Action + ) +checkCodes reqs expanded = + ( S.toList $ reqSet S.\\ foldMap sourceRequests mappings + , runIdentity $ M.traverseMaybeWithKey keepDuplicates mappings + , runIdentity $ M.traverseMaybeWithKey keepActions mappings + ) where + mappings :: Map (KeyMask, KeyCode) (Map Action (Set BindingRequest)) + mappings = M.fromListWith (M.unionWith S.union) + [ (binding, M.singleton act (S.singleton req)) + | ((req, act), binding) <- expanded + ] + + keepActions :: (KeyMask, KeyCode) -> Map Action (Set BindingRequest) -> Identity (Maybe Action) + keepActions _ = Identity . fmap fst . M.lookupMin + + keepDuplicates :: (KeyMask, KeyCode) -> Map Action (Set BindingRequest) -> Identity (Maybe (Set (BindingRequest, Action))) + keepDuplicates _ m = Identity $ if M.size m > 1 + then Just (sourceRequests m) + else Nothing + + sourceRequests :: Map Action (Set BindingRequest) -> Set (BindingRequest, Action) + sourceRequests = M.foldMapWithKey (\act -> S.map (flip (,) act)) + + reqSet :: Set (BindingRequest, Action) + reqSet = S.fromList reqs + +computeCodes :: Configuration -> Relation KeyCode KeySym -> + ( [(BindingRequest, Action)] + , Map (KeyMask, KeyCode) (Set (BindingRequest, Action)) + , Map (KeyMask, KeyCode) Action + ) +computeCodes conf = checkCodes (bindingRequests conf) . expandCodes conf + +computeBindings :: Spartacon (Map (KeyMask, KeyCode) Action) +computeBindings = do + conf <- asks configuration + (unbound, ambiguous, bs) <- computeCodes conf <$> gets keymap + unless (null unbound) $ do + io hPutStrLn stderr "WARNING: No keys found for the following binding requests:" + forM_ unbound $ io hPrintf stderr "\t%s\n" . pp + unless (M.null ambiguous) $ do + io hPutStrLn stderr "WARNING: Some binding requests conflict." + flip M.traverseWithKey ambiguous $ \binding@(mask, code) reqs -> io $ do + hPrintf stderr "\tThese binding requests are competing for mask %s, keycode %d" + (reverse . drop 1 . reverse . pp $ mask) + code + for_ (M.lookup binding bs) $ hPrintf stderr " (winner: %s)" . pp + hPutStrLn stderr ":" + for_ reqs $ hPrintf stderr "\t\t%s\n" . pp + pure () + pure bs + +refreshBindings :: Spartacon () +refreshBindings = do + bs <- gets bindings + bs' <- computeBindings + root <- askRoot + for_ (M.keysSet (bs M.\\ bs')) $ \(mask, code) -> x ungrabKey code mask root + for_ (M.keysSet (bs' M.\\ bs)) $ \(mask, code) -> x grabKey code mask root False grabModeAsync grabModeAsync + modify (\s -> s { bindings = bs' }) + +class PP a where pp :: a -> String + +instance PP Action where + pp Quit = "quit" + pp (Print t) = show t + +instance PP BindingRequest where + pp (BindingRequest mask code) = case (pp mask, pp code) of + -- atoms must start with a letter + ("", s@(c:_)) | c < 'A' || c > 'z' || (c > 'Z' && c < 'a') + -> "B-" ++ s + (s, s') -> s ++ s' + +instance PP (Either KeySym KeyCode) where + pp (Left sym) = keysymToString sym + pp (Right code) = "." ++ show code + +instance PP (BindingRequest, Action) where + pp (req, action) = pp req ++ ": " ++ pp action + +instance PP KeyMask where + pp mask = concat $ zipWith + (\label mask' -> if mask .&. mask' == 0 then "" else label ++ "-") + -- TODO: numlock/alt might not be mod2Mask/mod1Mask + ["NL", "L", "C", "A", "S", "M3", "M4", "M5"] + [mod2Mask, lockMask, controlMask, mod1Mask, shiftMask, mod3Mask, mod4Mask, mod5Mask] + +askRoot :: Spartacon Window +askRoot = asks (defaultRootWindow . display) + +instance C.HasSpec Configuration where + anySpec = C.sectionsSpec "configuration" $ pure Configuration + -- TODO: NL might not always be mod2Mask + <*> (nub . fromMaybe [mod2Mask] <$> C.optSection' "ignore" (C.listSpec C.anySpec) "keymasks to ignore when deciding whether a keypress matches (default: NL)") + <*> (fold <$> C.optSection' "bindings" bindingRequestsSpec "keys to watch for and the actions to take when they're pressed (default: no bindings)") + +bindingRequestsSpec :: C.ValueSpec [(BindingRequest, Action)] +bindingRequestsSpec = C.customSpec + "binding requests" + (C.assocSpec C.anySpec) + ( ppParseError "binding requests" + . traverse (\(req, act) -> flip (,) act <$> parseBindingRequest req) + ) + +instance C.HasSpec Action where + anySpec = (Quit <$ C.atomSpec "quit") C. (Quit <$ C.atomSpec "exit") + C. (Print <$> C.anySpec) + +instance C.HasSpec KeyMask where + anySpec = foldr1 (C.) [mask <$ C.atomSpec label | (label, mask) <- modifierMap] + +parseModifier :: Text -> Validation [(Text, [Text])] (Text, KeyMask) +parseModifier t = head $ + [ pure (T.drop (T.length t') t, m) + | (t', m) <- modifierMap + , t' `T.isPrefixOf` t + ] ++ [Failure [(t, fst <$> modifierMap)]] + +parseOnlyModifier :: Text -> Validation [(Text, [Text])] KeyMask +parseOnlyModifier t = case parseModifier t of + Success (t', m) + | T.null t' -> pure m + | otherwise -> Failure [(t', [""])] + Failure errs -> Failure errs + +parseKey :: Text -> Validation [(Text, [Text])] (Either KeySym KeyCode) +parseKey t + | T.isPrefixOf "." t = case reads . tail . T.unpack $ t of + (code, ""):_ -> pure (Right code) + (_, unparsed):_ -> Failure [(T.pack unparsed, [""])] + [] -> Failure [(T.drop 1 t, [""])] + | otherwise = case stringToKeysym . T.unpack $ t of + 0 -> Failure [(t, [""])] + sym -> pure (Left sym) + +parseBindingRequest :: Text -> Validation [(Text, [Text])] BindingRequest +parseBindingRequest t = case T.splitOn "-" t of + [] -> Failure [(t, [""])] + ts -> pure BindingRequest + <*> (foldr (.|.) noModMask <$> traverse parseOnlyModifier (init ts)) + <*> parseKey (last ts) + +-- TODO: alt/numlock aren't necessarily M1/M2 +modifierMap :: [(Text, KeyMask)] +modifierMap = concat . tail $ [undefined + , "S" ~> shiftMask + , "L" ~> lockMask + , "C" ~> controlMask + , "A" ~> mod1Mask + , "M1" ~> mod1Mask + , "NL" ~> mod2Mask + , "M2" ~> mod2Mask + , "M3" ~> mod3Mask + , "M4" ~> mod4Mask + , "M5" ~> mod5Mask + , "B" ~> noModMask -- blank; needed to bind 1-9 or keycodes with no modifier, since atoms must start with a letter + ] + where + t ~> m = [(t, m), (T.toLower t, m)] + +ppParseError :: Text -> Validation [(Text, [Text])] a -> Either Text a +ppParseError ty (Success a) = Right a +ppParseError ty (Failure errs) = Left . T.unlines . ("\tParsing of " <> ty <> " failed":) $ + [ msg + | (t, expecteds) <- errs + , msg <- ("\tat " <> t <> ", expected one of these:") : map ("\t\t"<>) expecteds + ] + +class SpartaClass a where + type Rebel a = r | r -> a + x :: (Display -> a) -> Rebel a + io :: a -> Rebel a + +instance SpartaClass (IO a) where + type Rebel (IO a) = Spartacon a + x f = ask >>= liftIO . f . display + io = liftIO + +instance SpartaClass b => SpartaClass (a -> b) where + type Rebel (a -> b) = a -> Rebel b + x f = x . flip f + io f = io . f diff --git a/spartacon.cabal b/spartacon.cabal new file mode 100644 --- /dev/null +++ b/spartacon.cabal @@ -0,0 +1,51 @@ +cabal-version: 2.4 +name: spartacon +version: 0.1.0.0 +extra-source-files: README.md +category: Control + +-- A short (one-line) description of the package. +synopsis: A unix-style (read from stdin, write to stdout) global hotkey daemon + +-- A longer description of the package. +description: __spartacon__ is a Unix-style global hotkey daemon. It embraces the philosophies of "do one thing, and do it well" and "text in, text out". It allows you to capture hotkeys on X11, without having any strong opinions about what actions should happen when those keys are pressed. + . + There are other hotkey applications out there; for example, modern desktop environments typically have a way to bind keys to actions, and there are standalone apps like . Typically, these implementations assume that the thing you want to happen when a key is hit is to launch a process. If what you really want is to just add hotkey functionality to an existing application without it needing to know how to do that, those are typically not suitable, because the tool being controlled is already running. + . + spartacon sits in that space: when you want to control a "text in, text out"-style program with hotkeys, this is the tool for you. (And if you decide to pipe spartacon to something that launches processes, that's no skin off my teeth!) + + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +license: BSD-3-Clause +license-file: LICENSE +author: Daniel Wagner +maintainer: me@dmwit.com + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable spartacon + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + , config-schema ^>=1.2.2 + , config-value ^>=0.8 + , containers ^>=0.6 + , either ^>=5.0 + , mtl ^>=2.2 + , relation ^>=0.5 + , text ^>=1.2 + , X11 ^>=1.9 + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -fno-warn-tabs