ndwarshuis
/
xman
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF use rio and such

This commit is contained in:
Nathan Dwarshuis 2023-02-13 21:40:26 -05:00
parent 14fb8e98fb
commit 7eacd0134f
6 changed files with 179 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -1,4 +1,5 @@
.stack-work/ .stack-work/
stack.yaml.lock stack.yaml.lock
TAGS TAGS
xman.cabal
*~ *~

164
app/Main.hs
View File

@ -1,8 +1,5 @@
{-# 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
@ -25,53 +22,51 @@
module Main (main) where module Main (main) where
import Control.Monad (forM_, forever, void, when) import qualified Data.Text.IO as TI
import Control.Monad.Reader import Graphics.X11.Types
import Control.Monad.State import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Data.List (any) import Graphics.X11.Xlib.Event
import Data.Maybe (isJust) import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc
import Graphics.X11.Types import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Atom import RIO hiding (Display, display, handle)
import Graphics.X11.Xlib.Display import RIO.Directory
import Graphics.X11.Xlib.Event import RIO.State
import Graphics.X11.Xlib.Extras import System.Environment
import Graphics.X11.Xlib.Misc import System.Posix.IO
import Graphics.X11.Xlib.Types import System.Posix.Signals
import System.Process
import Text.Regex.TDFA import Text.Regex.TDFA
import System.Directory
import System.Environment
import System.Posix.IO
import System.Posix.Signals
import System.Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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)
instance Applicative XMan where newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a)
pure = return deriving
(<*>) = ap ( Functor
, 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
, theRoot :: Window , theRoot :: Window
, netActiveWindow :: Atom , netActiveWindow :: Atom
, regexps :: Patterns , regexps :: Patterns
, xcapeProcess :: CreateProcess , xcapeProcess :: CreateProcess
} }
-- | timeout for xcape -- | timeout for xcape
type Timeout = Maybe String type Timeout = Maybe String
@ -92,10 +87,10 @@ 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
xcapeExe :: String xcapeExe :: String
xcapeExe = "xcape" xcapeExe = "xcape"
@ -104,55 +99,61 @@ xcapeExe = "xcape"
-- run xcape in debug mode (which will make it run as a foreground process, -- run xcape in debug mode (which will make it run as a foreground process,
-- otherwise it will fork unnecessarily). -- otherwise it will fork unnecessarily).
mkXcapeProcess :: Timeout -> Bindings -> CreateProcess mkXcapeProcess :: Timeout -> Bindings -> CreateProcess
mkXcapeProcess (Just t) b = proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b] mkXcapeProcess (Just t) b = proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b]
mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b] mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
-- | Print the usage and exit -- | Print the usage and exit
usage :: IO () usage :: IO ()
usage = putStrLn "xman [-t TIMEOUT] BINDINGS REGEXP [[REGEXP] ...]" usage = TI.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 putStrLn "could not find xcape binary" if r then initX else TI.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
dpy <- openDisplay "" withDisplay $ \dpy -> do
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 = XMConf let cf =
{ display = dpy XMConf
, theRoot = root { display = dpy
, netActiveWindow = naw , theRoot = root
, regexps = rs , netActiveWindow = naw
, xcapeProcess = cp , regexps = rs
} , xcapeProcess = cp
st = XMState { xcapeHandle = Nothing } }
-- listen only for PropertyNotify events on the root window st = XMState {xcapeHandle = Nothing}
allocaSetWindowAttributes $ \a -> do -- listen only for PropertyNotify events on the root window
set_event_mask a propertyChangeMask allocaSetWindowAttributes $ \a -> do
changeWindowAttributes dpy root cWEventMask a set_event_mask a propertyChangeMask
void $ allocaXEvent $ \e -> changeWindowAttributes dpy root cWEventMask a
runXMan cf st $ do allocaXEvent $ \e ->
updateXCape -- set the initial state before entering main loop runXMan cf st $ do
forever $ handle =<< io (nextEvent dpy e >> getEvent e) updateXCape -- set the initial state before entering main loop
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
withDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
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
-- | Lift an IO monad into the XMan context -- | Lift an IO monad into the XMan context
io :: MonadIO m => IO a -> m a 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 (a, XMState) runXMan :: XMConf -> XMState -> XMan a -> IO ()
runXMan c s (XMan a) = runStateT (runReaderT a c) s runXMan c s (XMan a) = void $ 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 ()
@ -165,21 +166,22 @@ updateXCape = do
prop <- io $ getWindowProperty32 dpy atom root prop <- io $ getWindowProperty32 dpy atom root
case prop of case prop of
Just [aw] -> getAppName (fromIntegral aw) >>= startOrKillXCape Just [aw] -> getAppName (fromIntegral aw) >>= startOrKillXCape
_ -> startXCape _ -> startXCape
-- | Given an event, call a handler. In this case the only thing we care about -- | Given an event, call a handler. In this case the only thing we care about
-- 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 = io . fmap resName . permitBadWindow . flip getClassHint w =<< getAppName w =
asks display io . fmap resName . permitBadWindow . flip getClassHint w
=<< 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
@ -196,9 +198,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 _ = print "actual error" handleError _ = TI.putStrLn "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
@ -214,8 +216,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 $ print "started xcape" io $ TI.putStrLn "started xcape"
-- | Stop xcape if it is running -- | Stop xcape if it is running
stopXCape :: XMan () stopXCape :: XMan ()
@ -223,8 +225,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 $ print "stopped xcape" io $ TI.putStrLn "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
@ -235,5 +237,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

14
fourmolu.yaml Normal file
View File

@ -0,0 +1,14 @@
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 Normal file
View File

@ -0,0 +1,80 @@
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

2
stack.yaml
View File

@ -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-14.12 resolver: lts-20.11
# 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.

38
xman.cabal
View File

@ -1,38 +0,0 @@
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