REF use rio and such
This commit is contained in:
parent
14fb8e98fb
commit
7eacd0134f
|
|
@ -1,4 +1,5 @@
|
|||
.stack-work/
|
||||
stack.yaml.lock
|
||||
TAGS
|
||||
xman.cabal
|
||||
*~
|
||||
|
|
|
|||
164
app/Main.hs
164
app/Main.hs
|
|
@ -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
|
||||
-- for making custom keymaps. However, it is not always desirable to have this
|
||||
|
|
@ -25,53 +22,51 @@
|
|||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (forM_, forever, void, when)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
import Data.List (any)
|
||||
import Data.Maybe (isJust)
|
||||
|
||||
import Graphics.X11.Types
|
||||
import Graphics.X11.Xlib.Atom
|
||||
import Graphics.X11.Xlib.Display
|
||||
import Graphics.X11.Xlib.Event
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Graphics.X11.Xlib.Misc
|
||||
import Graphics.X11.Xlib.Types
|
||||
|
||||
import Text.Regex.TDFA
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Posix.IO
|
||||
import System.Posix.Signals
|
||||
import System.Process
|
||||
import qualified Data.Text.IO as TI
|
||||
import Graphics.X11.Types
|
||||
import Graphics.X11.Xlib.Atom
|
||||
import Graphics.X11.Xlib.Display
|
||||
import Graphics.X11.Xlib.Event
|
||||
import Graphics.X11.Xlib.Extras
|
||||
import Graphics.X11.Xlib.Misc
|
||||
import Graphics.X11.Xlib.Types
|
||||
import RIO hiding (Display, display, handle)
|
||||
import RIO.Directory
|
||||
import RIO.State
|
||||
import System.Environment
|
||||
import System.Posix.IO
|
||||
import System.Posix.Signals
|
||||
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
|
||||
-- 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.
|
||||
--
|
||||
-- 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
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a)
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadState XMState
|
||||
, MonadReader XMConf
|
||||
)
|
||||
|
||||
newtype XMState = XMState { xcapeHandle :: Maybe ProcessHandle }
|
||||
newtype XMState = XMState {xcapeHandle :: Maybe ProcessHandle}
|
||||
|
||||
data XMConf = XMConf
|
||||
{ display :: Display
|
||||
, theRoot :: Window
|
||||
, netActiveWindow :: Atom
|
||||
, regexps :: Patterns
|
||||
, xcapeProcess :: CreateProcess
|
||||
}
|
||||
{ display :: Display
|
||||
, theRoot :: Window
|
||||
, netActiveWindow :: Atom
|
||||
, regexps :: Patterns
|
||||
, xcapeProcess :: CreateProcess
|
||||
}
|
||||
|
||||
-- | timeout for xcape
|
||||
type Timeout = Maybe String
|
||||
|
|
@ -92,10 +87,10 @@ main = getArgs >>= parse
|
|||
|
||||
-- | Given a list of arguments, either start the program or print the usage
|
||||
parse :: [String] -> IO ()
|
||||
parse [_] = usage
|
||||
parse ("-t":t:b:rs) = initXMan rs $ mkXcapeProcess (Just t) b
|
||||
parse (b:rs) = initXMan rs $ mkXcapeProcess Nothing b
|
||||
parse _ = usage
|
||||
parse [_] = usage
|
||||
parse ("-t" : t : b : rs) = initXMan rs $ mkXcapeProcess (Just t) b
|
||||
parse (b : rs) = initXMan rs $ mkXcapeProcess Nothing b
|
||||
parse _ = usage
|
||||
|
||||
xcapeExe :: String
|
||||
xcapeExe = "xcape"
|
||||
|
|
@ -104,55 +99,61 @@ xcapeExe = "xcape"
|
|||
-- run xcape in debug mode (which will make it run as a foreground process,
|
||||
-- otherwise it will fork unnecessarily).
|
||||
mkXcapeProcess :: Timeout -> Bindings -> CreateProcess
|
||||
mkXcapeProcess (Just t) b = proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b]
|
||||
mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
|
||||
mkXcapeProcess (Just t) b = proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b]
|
||||
mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
|
||||
|
||||
-- | Print the usage and exit
|
||||
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
|
||||
-- titles we care about, initialize the XMan monad and run the main event loop
|
||||
initXMan :: Patterns -> CreateProcess -> IO ()
|
||||
initXMan rs cp = do
|
||||
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
|
||||
initX = do
|
||||
-- ignore SIGCHLD so we don't produce zombie processes
|
||||
void $ installHandler sigCHLD Ignore Nothing
|
||||
dpy <- openDisplay ""
|
||||
root <- rootWindow dpy $ defaultScreen dpy
|
||||
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
||||
let cf = XMConf
|
||||
{ display = dpy
|
||||
, theRoot = root
|
||||
, netActiveWindow = naw
|
||||
, regexps = rs
|
||||
, xcapeProcess = cp
|
||||
}
|
||||
st = XMState { xcapeHandle = Nothing }
|
||||
-- listen only for PropertyNotify events on the root window
|
||||
allocaSetWindowAttributes $ \a -> do
|
||||
set_event_mask a propertyChangeMask
|
||||
changeWindowAttributes dpy root cWEventMask a
|
||||
void $ allocaXEvent $ \e ->
|
||||
runXMan cf st $ do
|
||||
updateXCape -- set the initial state before entering main loop
|
||||
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
||||
withDisplay $ \dpy -> do
|
||||
root <- rootWindow dpy $ defaultScreen dpy
|
||||
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
||||
let cf =
|
||||
XMConf
|
||||
{ display = dpy
|
||||
, theRoot = root
|
||||
, netActiveWindow = naw
|
||||
, regexps = rs
|
||||
, xcapeProcess = cp
|
||||
}
|
||||
st = XMState {xcapeHandle = Nothing}
|
||||
-- listen only for PropertyNotify events on the root window
|
||||
allocaSetWindowAttributes $ \a -> do
|
||||
set_event_mask a propertyChangeMask
|
||||
changeWindowAttributes dpy root cWEventMask a
|
||||
allocaXEvent $ \e ->
|
||||
runXMan cf st $ do
|
||||
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 = isJust <$> findExecutable xcapeExe
|
||||
|
||||
|
||||
|
||||
-- | Lift an IO monad into the XMan context
|
||||
io :: MonadIO m => IO a -> m a
|
||||
io = liftIO
|
||||
|
||||
-- | Given an initial state and configuration, run the XMan monad
|
||||
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
|
||||
runXMan c s (XMan a) = runStateT (runReaderT a c) s
|
||||
runXMan :: XMConf -> XMState -> XMan a -> IO ()
|
||||
runXMan c s (XMan a) = void $ runStateT (runReaderT a c) s
|
||||
|
||||
-- | Update the xcape status given the state of XMan
|
||||
updateXCape :: XMan ()
|
||||
|
|
@ -165,21 +166,22 @@ updateXCape = do
|
|||
prop <- io $ getWindowProperty32 dpy atom root
|
||||
case prop of
|
||||
Just [aw] -> getAppName (fromIntegral aw) >>= startOrKillXCape
|
||||
_ -> startXCape
|
||||
_ -> startXCape
|
||||
|
||||
-- | 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
|
||||
-- initiated the xcape update logic.
|
||||
handle :: Event -> XMan ()
|
||||
handle PropertyEvent { ev_atom = a } = do
|
||||
handle PropertyEvent {ev_atom = a} = do
|
||||
atom <- asks netActiveWindow
|
||||
when (a == atom) updateXCape
|
||||
handle _ = return ()
|
||||
|
||||
-- | Given a window, return its app name
|
||||
getAppName :: Window -> XMan AppName
|
||||
getAppName w = io . fmap resName . permitBadWindow . flip getClassHint w =<<
|
||||
asks display
|
||||
getAppName w =
|
||||
io . fmap resName . permitBadWindow . flip getClassHint w
|
||||
=<< asks display
|
||||
|
||||
-- | 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
|
||||
|
|
@ -196,9 +198,9 @@ permitBadWindow action = do
|
|||
return res
|
||||
where
|
||||
-- TODO also ignore badvalue errors?
|
||||
handleError ErrorEvent { ev_error_code = t }
|
||||
handleError ErrorEvent {ev_error_code = t}
|
||||
| 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
|
||||
-- regular expressions in XMan
|
||||
|
|
@ -214,8 +216,8 @@ startXCape = do
|
|||
unless (isJust pID) $ do
|
||||
cp <- asks xcapeProcess
|
||||
h <- io $ createProcessNull cp
|
||||
modify $ \s -> s { xcapeHandle = Just h }
|
||||
io $ print "started xcape"
|
||||
modify $ \s -> s {xcapeHandle = Just h}
|
||||
io $ TI.putStrLn "started xcape"
|
||||
|
||||
-- | Stop xcape if it is running
|
||||
stopXCape :: XMan ()
|
||||
|
|
@ -223,8 +225,8 @@ stopXCape = do
|
|||
pID <- gets xcapeHandle
|
||||
forM_ pID $ \p -> do
|
||||
io $ terminateProcess p
|
||||
modify $ \s -> s { xcapeHandle = Nothing }
|
||||
io $ print "stopped xcape"
|
||||
modify $ \s -> s {xcapeHandle = Nothing}
|
||||
io $ TI.putStrLn "stopped xcape"
|
||||
|
||||
-- | Given a createProcess record, start the process with stderr and stdout
|
||||
-- redirected to the null device
|
||||
|
|
@ -235,5 +237,5 @@ createProcessNull :: CreateProcess -> IO ProcessHandle
|
|||
createProcessNull cp = do
|
||||
fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
||||
dn <- UseHandle <$> fdToHandle fd
|
||||
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
||||
(_, _, _, h) <- createProcess $ cp {std_err = dn, std_out = dn}
|
||||
return h
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-14.12
|
||||
resolver: lts-20.11
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
|
|
|
|||
38
xman.cabal
38
xman.cabal
|
|
@ -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
|
||||
|
||||
Loading…
Reference in New Issue