Compare commits
1 Commits
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | fb8e9fb353 |
|
@ -1,5 +1,4 @@
|
||||||
.stack-work/
|
.stack-work/
|
||||||
stack.yaml.lock
|
stack.yaml.lock
|
||||||
TAGS
|
TAGS
|
||||||
xman.cabal
|
|
||||||
*~
|
*~
|
||||||
|
|
89
app/Main.hs
89
app/Main.hs
|
@ -1,5 +1,8 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Xcape MANager (XMan) - a wrapper for managing xcape
|
-- | Xcape MANager (XMan) - a wrapper for managing xcape
|
||||||
--
|
--
|
||||||
-- xcape is a program to map keyrelease events to keysyms, and is very useful
|
-- xcape is a program to map keyrelease events to keysyms, and is very useful
|
||||||
-- for making custom keymaps. However, it is not always desirable to have this
|
-- for making custom keymaps. However, it is not always desirable to have this
|
||||||
|
@ -22,7 +25,12 @@
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import qualified Data.Text.IO as TI
|
import Control.Monad
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
import Data.Maybe (isJust)
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
|
@ -30,35 +38,31 @@ import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import Graphics.X11.Xlib.Misc
|
import Graphics.X11.Xlib.Misc
|
||||||
import Graphics.X11.Xlib.Types
|
import Graphics.X11.Xlib.Types
|
||||||
import RIO hiding (Display, display, handle)
|
|
||||||
import RIO.Directory
|
import Text.Regex.TDFA
|
||||||
import RIO.State
|
|
||||||
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Posix.IO
|
import System.Posix.IO
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
import System.Process
|
import System.Process
|
||||||
import Text.Regex.TDFA
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Central State+Reader+IO Monad (I wonder where this idea came from...)
|
-- | Central State+Reader+IO Monad (I wonder where this idea came from...)
|
||||||
--
|
--
|
||||||
-- The Reader portion holds some of the key data structures from X that we care
|
-- The Reader portion holds some of the key data structures from X that we care
|
||||||
-- about as well as the regular expression patterns to match the app names we
|
-- about as well as the regular expression patterns to match the app names we
|
||||||
-- care about and and the bindings to pass to the xcape command.
|
-- care about and and the bindings to pass to the xcape command.
|
||||||
--
|
--
|
||||||
-- The State portion holds the xcape process handle (so we can kill it later)
|
-- The State portion holds the xcape process handle (so we can kill it later)
|
||||||
|
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
|
||||||
|
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
|
||||||
|
|
||||||
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a)
|
instance Applicative XMan where
|
||||||
deriving
|
pure = return
|
||||||
( Functor
|
(<*>) = ap
|
||||||
, Applicative
|
|
||||||
, Monad
|
|
||||||
, MonadIO
|
|
||||||
, MonadState XMState
|
|
||||||
, MonadReader XMConf
|
|
||||||
)
|
|
||||||
|
|
||||||
newtype XMState = XMState {xcapeHandle :: Maybe ProcessHandle}
|
newtype XMState = XMState { xcapeHandle :: Maybe ProcessHandle }
|
||||||
|
|
||||||
data XMConf = XMConf
|
data XMConf = XMConf
|
||||||
{ display :: Display
|
{ display :: Display
|
||||||
|
@ -88,10 +92,11 @@ main = getArgs >>= parse
|
||||||
-- | Given a list of arguments, either start the program or print the usage
|
-- | Given a list of arguments, either start the program or print the usage
|
||||||
parse :: [String] -> IO ()
|
parse :: [String] -> IO ()
|
||||||
parse [_] = usage
|
parse [_] = usage
|
||||||
parse ("-t" : t : b : rs) = initXMan rs $ mkXcapeProcess (Just t) b
|
parse ("-t":t:b:rs) = initXMan rs $ mkXcapeProcess (Just t) b
|
||||||
parse (b : rs) = initXMan rs $ mkXcapeProcess Nothing b
|
parse (b:rs) = initXMan rs $ mkXcapeProcess Nothing b
|
||||||
parse _ = usage
|
parse _ = usage
|
||||||
|
|
||||||
|
-- | The name of the xcape executable
|
||||||
xcapeExe :: String
|
xcapeExe :: String
|
||||||
xcapeExe = "xcape"
|
xcapeExe = "xcape"
|
||||||
|
|
||||||
|
@ -104,46 +109,39 @@ mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
|
||||||
|
|
||||||
-- | Print the usage and exit
|
-- | Print the usage and exit
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = TI.putStrLn "xman [-t TIMEOUT] BINDINGS REGEXP [[REGEXP] ...]"
|
usage = putStrLn "xman [-t TIMEOUT] BINDINGS REGEXP [[REGEXP] ...]"
|
||||||
|
|
||||||
-- | Given xcape bindings and regular expression patterns to match the window
|
-- | Given xcape bindings and regular expression patterns to match the window
|
||||||
-- titles we care about, initialize the XMan monad and run the main event loop
|
-- titles we care about, initialize the XMan monad and run the main event loop
|
||||||
initXMan :: Patterns -> CreateProcess -> IO ()
|
initXMan :: Patterns -> CreateProcess -> IO ()
|
||||||
initXMan rs cp = do
|
initXMan rs cp = do
|
||||||
r <- checkXcape
|
r <- checkXcape
|
||||||
if r then initX else TI.putStrLn "could not find xcape binary"
|
if r then initX else putStrLn "could not find xcape binary"
|
||||||
where
|
where
|
||||||
initX = do
|
initX = do
|
||||||
-- ignore SIGCHLD so we don't produce zombie processes
|
-- ignore SIGCHLD so we don't produce zombie processes
|
||||||
void $ installHandler sigCHLD Ignore Nothing
|
void $ installHandler sigCHLD Ignore Nothing
|
||||||
withDisplay $ \dpy -> do
|
dpy <- openDisplay ""
|
||||||
root <- rootWindow dpy $ defaultScreen dpy
|
root <- rootWindow dpy $ defaultScreen dpy
|
||||||
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
||||||
let cf =
|
let cf = XMConf
|
||||||
XMConf
|
|
||||||
{ display = dpy
|
{ display = dpy
|
||||||
, theRoot = root
|
, theRoot = root
|
||||||
, netActiveWindow = naw
|
, netActiveWindow = naw
|
||||||
, regexps = rs
|
, regexps = rs
|
||||||
, xcapeProcess = cp
|
, xcapeProcess = cp
|
||||||
}
|
}
|
||||||
st = XMState {xcapeHandle = Nothing}
|
st = XMState { xcapeHandle = Nothing }
|
||||||
-- listen only for PropertyNotify events on the root window
|
-- listen only for PropertyNotify events on the root window
|
||||||
allocaSetWindowAttributes $ \a -> do
|
allocaSetWindowAttributes $ \a -> do
|
||||||
set_event_mask a propertyChangeMask
|
set_event_mask a propertyChangeMask
|
||||||
changeWindowAttributes dpy root cWEventMask a
|
changeWindowAttributes dpy root cWEventMask a
|
||||||
allocaXEvent $ \e ->
|
void $ allocaXEvent $ \e ->
|
||||||
runXMan cf st $ do
|
runXMan cf st $ do
|
||||||
updateXCape -- set the initial state before entering main loop
|
updateXCape -- set the initial state before entering main loop
|
||||||
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
withDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
|
-- | Return true if xcape is installed
|
||||||
withDisplay = bracket (liftIO $ openDisplay "") cleanup
|
|
||||||
where
|
|
||||||
cleanup dpy = liftIO $ do
|
|
||||||
flush dpy
|
|
||||||
closeDisplay dpy
|
|
||||||
|
|
||||||
checkXcape :: IO Bool
|
checkXcape :: IO Bool
|
||||||
checkXcape = isJust <$> findExecutable xcapeExe
|
checkXcape = isJust <$> findExecutable xcapeExe
|
||||||
|
|
||||||
|
@ -152,8 +150,8 @@ io :: MonadIO m => IO a -> m a
|
||||||
io = liftIO
|
io = liftIO
|
||||||
|
|
||||||
-- | Given an initial state and configuration, run the XMan monad
|
-- | Given an initial state and configuration, run the XMan monad
|
||||||
runXMan :: XMConf -> XMState -> XMan a -> IO ()
|
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
|
||||||
runXMan c s (XMan a) = void $ runStateT (runReaderT a c) s
|
runXMan c s (XMan a) = runStateT (runReaderT a c) s
|
||||||
|
|
||||||
-- | Update the xcape status given the state of XMan
|
-- | Update the xcape status given the state of XMan
|
||||||
updateXCape :: XMan ()
|
updateXCape :: XMan ()
|
||||||
|
@ -172,16 +170,15 @@ updateXCape = do
|
||||||
-- are PropertyNotify events where the atom is _NET_ACTIVE_WINDOW, which will
|
-- are PropertyNotify events where the atom is _NET_ACTIVE_WINDOW, which will
|
||||||
-- initiated the xcape update logic.
|
-- initiated the xcape update logic.
|
||||||
handle :: Event -> XMan ()
|
handle :: Event -> XMan ()
|
||||||
handle PropertyEvent {ev_atom = a} = do
|
handle PropertyEvent { ev_atom = a } = do
|
||||||
atom <- asks netActiveWindow
|
atom <- asks netActiveWindow
|
||||||
when (a == atom) updateXCape
|
when (a == atom) updateXCape
|
||||||
handle _ = return ()
|
handle _ = return ()
|
||||||
|
|
||||||
-- | Given a window, return its app name
|
-- | Given a window, return its app name
|
||||||
getAppName :: Window -> XMan AppName
|
getAppName :: Window -> XMan AppName
|
||||||
getAppName w =
|
getAppName w = io . fmap resName . permitBadWindow . flip getClassHint w =<<
|
||||||
io . fmap resName . permitBadWindow . flip getClassHint w
|
asks display
|
||||||
=<< asks display
|
|
||||||
|
|
||||||
-- | Given an IO action (which is assumed to call an XLib function that may
|
-- | Given an IO action (which is assumed to call an XLib function that may
|
||||||
-- throw an error), attach an error handler before performing the action and
|
-- throw an error), attach an error handler before performing the action and
|
||||||
|
@ -198,9 +195,9 @@ permitBadWindow action = do
|
||||||
return res
|
return res
|
||||||
where
|
where
|
||||||
-- TODO also ignore badvalue errors?
|
-- TODO also ignore badvalue errors?
|
||||||
handleError ErrorEvent {ev_error_code = t}
|
handleError ErrorEvent { ev_error_code = t }
|
||||||
| fromIntegral t == badWindow = return ()
|
| fromIntegral t == badWindow = return ()
|
||||||
handleError _ = TI.putStrLn "actual error"
|
handleError _ = print "actual error"
|
||||||
|
|
||||||
-- | Given an app name, start or stop xcape if it matches any of the supplied
|
-- | Given an app name, start or stop xcape if it matches any of the supplied
|
||||||
-- regular expressions in XMan
|
-- regular expressions in XMan
|
||||||
|
@ -216,8 +213,8 @@ startXCape = do
|
||||||
unless (isJust pID) $ do
|
unless (isJust pID) $ do
|
||||||
cp <- asks xcapeProcess
|
cp <- asks xcapeProcess
|
||||||
h <- io $ createProcessNull cp
|
h <- io $ createProcessNull cp
|
||||||
modify $ \s -> s {xcapeHandle = Just h}
|
modify $ \s -> s { xcapeHandle = Just h }
|
||||||
io $ TI.putStrLn "started xcape"
|
io $ print "started xcape"
|
||||||
|
|
||||||
-- | Stop xcape if it is running
|
-- | Stop xcape if it is running
|
||||||
stopXCape :: XMan ()
|
stopXCape :: XMan ()
|
||||||
|
@ -225,8 +222,8 @@ stopXCape = do
|
||||||
pID <- gets xcapeHandle
|
pID <- gets xcapeHandle
|
||||||
forM_ pID $ \p -> do
|
forM_ pID $ \p -> do
|
||||||
io $ terminateProcess p
|
io $ terminateProcess p
|
||||||
modify $ \s -> s {xcapeHandle = Nothing}
|
modify $ \s -> s { xcapeHandle = Nothing }
|
||||||
io $ TI.putStrLn "stopped xcape"
|
io $ print "stopped xcape"
|
||||||
|
|
||||||
-- | Given a createProcess record, start the process with stderr and stdout
|
-- | Given a createProcess record, start the process with stderr and stdout
|
||||||
-- redirected to the null device
|
-- redirected to the null device
|
||||||
|
@ -237,5 +234,5 @@ createProcessNull :: CreateProcess -> IO ProcessHandle
|
||||||
createProcessNull cp = do
|
createProcessNull cp = do
|
||||||
fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
||||||
dn <- UseHandle <$> fdToHandle fd
|
dn <- UseHandle <$> fdToHandle fd
|
||||||
(_, _, _, h) <- createProcess $ cp {std_err = dn, std_out = dn}
|
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
||||||
return h
|
return h
|
||||||
|
|
|
@ -1,14 +0,0 @@
|
||||||
indentation: 2
|
|
||||||
function-arrows: leading
|
|
||||||
comma-style: leading
|
|
||||||
import-export-style: leading
|
|
||||||
indent-wheres: true
|
|
||||||
record-brace-space: true
|
|
||||||
newlines-between-decls: 1
|
|
||||||
haddock-style: single-line
|
|
||||||
haddock-style-module:
|
|
||||||
let-style: inline
|
|
||||||
in-style: right-align
|
|
||||||
respectful: false
|
|
||||||
fixities: []
|
|
||||||
unicode: never
|
|
80
package.yaml
80
package.yaml
|
@ -1,80 +0,0 @@
|
||||||
name: xman
|
|
||||||
version: 0.1.0.0
|
|
||||||
github: "ndwarshuis/xman"
|
|
||||||
license: BSD3
|
|
||||||
author: "Nathan Dwarshuis"
|
|
||||||
maintainer: "ndwar@yavin4.ch"
|
|
||||||
copyright: "2022 Nathan Dwarshuis"
|
|
||||||
|
|
||||||
extra-source-files:
|
|
||||||
- README.md
|
|
||||||
|
|
||||||
description: Please see the README on GitHub at <https://github.com/ndwarshuis/xman#readme>
|
|
||||||
|
|
||||||
default-extensions:
|
|
||||||
- OverloadedStrings
|
|
||||||
- FlexibleContexts
|
|
||||||
- FlexibleInstances
|
|
||||||
- InstanceSigs
|
|
||||||
- MultiParamTypeClasses
|
|
||||||
- EmptyCase
|
|
||||||
- LambdaCase
|
|
||||||
- MultiWayIf
|
|
||||||
- NamedFieldPuns
|
|
||||||
- TupleSections
|
|
||||||
- DeriveFoldable
|
|
||||||
- DeriveFunctor
|
|
||||||
- DeriveGeneric
|
|
||||||
- DeriveLift
|
|
||||||
- DeriveTraversable
|
|
||||||
- DerivingStrategies
|
|
||||||
- DeriveDataTypeable
|
|
||||||
- EmptyDataDecls
|
|
||||||
- PartialTypeSignatures
|
|
||||||
- GeneralizedNewtypeDeriving
|
|
||||||
- StandaloneDeriving
|
|
||||||
- BangPatterns
|
|
||||||
- TypeOperators
|
|
||||||
- ScopedTypeVariables
|
|
||||||
- TypeApplications
|
|
||||||
- ConstraintKinds
|
|
||||||
- RankNTypes
|
|
||||||
- GADTs
|
|
||||||
- DefaultSignatures
|
|
||||||
- NoImplicitPrelude
|
|
||||||
- FunctionalDependencies
|
|
||||||
- DataKinds
|
|
||||||
- TypeFamilies
|
|
||||||
- BinaryLiterals
|
|
||||||
- ViewPatterns
|
|
||||||
|
|
||||||
ghc-options:
|
|
||||||
- -Wall
|
|
||||||
- -Wcompat
|
|
||||||
- -Widentities
|
|
||||||
- -Wincomplete-record-updates
|
|
||||||
- -Wincomplete-uni-patterns
|
|
||||||
- -Wredundant-constraints
|
|
||||||
- -Wpartial-fields
|
|
||||||
- -Werror
|
|
||||||
- -O2
|
|
||||||
|
|
||||||
dependencies:
|
|
||||||
- base >=4.7 && <5
|
|
||||||
- X11
|
|
||||||
- text
|
|
||||||
- mtl >= 2.2.2
|
|
||||||
- unix >= 2.7.2.2
|
|
||||||
- regex-tdfa >= 1.2.3.2
|
|
||||||
- process >= 1.6.5.0
|
|
||||||
- directory >= 1.3.3.0
|
|
||||||
- rio
|
|
||||||
|
|
||||||
executables:
|
|
||||||
xman:
|
|
||||||
main: Main.hs
|
|
||||||
source-dirs: app
|
|
||||||
ghc-options:
|
|
||||||
- -threaded
|
|
||||||
- -rtsopts
|
|
||||||
- -with-rtsopts=-N
|
|
10
stack.yaml
10
stack.yaml
|
@ -17,7 +17,7 @@
|
||||||
#
|
#
|
||||||
# resolver: ./custom-snapshot.yaml
|
# resolver: ./custom-snapshot.yaml
|
||||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
resolver: lts-20.11
|
resolver: lts-16.31
|
||||||
|
|
||||||
# User packages to be built.
|
# User packages to be built.
|
||||||
# Various formats can be used as shown in the example below.
|
# Various formats can be used as shown in the example below.
|
||||||
|
@ -64,3 +64,11 @@ packages:
|
||||||
#
|
#
|
||||||
# Allow a newer minor version of GHC than the snapshot specifies
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
# compiler-check: newer-minor
|
# compiler-check: newer-minor
|
||||||
|
nix:
|
||||||
|
enable: true
|
||||||
|
packages:
|
||||||
|
- xorg.libxcb
|
||||||
|
- xorg.libXrender
|
||||||
|
- xorg.libXrandr
|
||||||
|
- xorg.libXScrnSaver
|
||||||
|
- xorg.libXext
|
||||||
|
|
|
@ -0,0 +1,38 @@
|
||||||
|
cabal-version: 1.12
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
--
|
||||||
|
-- hash: 32a585abcde8be89acd003c83fd878360a2fa7ed9a02418cbcbf6539cfd85401
|
||||||
|
|
||||||
|
name: xman
|
||||||
|
version: 0.1.0.0
|
||||||
|
description: Please see the README on GitHub at <https://github.com/ndwarshuis/xman-hs#readme>
|
||||||
|
homepage: https://github.com/ndwarshuis/xman-hs#readme
|
||||||
|
bug-reports: https://github.com/ndwarshuis/xman-hs/issues
|
||||||
|
author: Nathan Dwarshuis
|
||||||
|
maintainer: ndwar@yavin4.ch
|
||||||
|
copyright: 2020 Nathan Dwarshuis
|
||||||
|
license: BSD3
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
extra-source-files:
|
||||||
|
README.md
|
||||||
|
|
||||||
|
executable xman
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs:
|
||||||
|
app
|
||||||
|
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded -rtsopts -with-rtsopts=-N
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, X11
|
||||||
|
, mtl >= 2.2.2
|
||||||
|
, unix >= 2.7.2.2
|
||||||
|
, regex-tdfa >= 1.2.3.2
|
||||||
|
, process >= 1.6.5.0
|
||||||
|
, directory >= 1.3.3.0
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
Loading…
Reference in New Issue