Compare commits

..

1 Commits

Author SHA1 Message Date
Nathan Dwarshuis fb8e9fb353 ENH use nix 2022-07-23 00:38:24 -04:00
7 changed files with 127 additions and 184 deletions

1
.gitignore vendored
View File

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

View File

@ -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
-- for making custom keymaps. However, it is not always desirable to have this
@ -22,7 +25,12 @@
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.Xlib.Atom
import Graphics.X11.Xlib.Display
@ -30,33 +38,29 @@ 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 Text.Regex.TDFA
import System.Directory
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)
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a)
deriving
( Functor
, Applicative
, Monad
, MonadIO
, MonadState XMState
, MonadReader XMConf
)
instance Applicative XMan where
pure = return
(<*>) = ap
newtype XMState = XMState { xcapeHandle :: Maybe ProcessHandle }
@ -92,6 +96,7 @@ parse ("-t" : t : b : rs) = initXMan rs $ mkXcapeProcess (Just t) b
parse (b:rs) = initXMan rs $ mkXcapeProcess Nothing b
parse _ = usage
-- | The name of the xcape executable
xcapeExe :: String
xcapeExe = "xcape"
@ -104,23 +109,22 @@ mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
-- | Print the usage and exit
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
-- 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 TI.putStrLn "could not find xcape binary"
if r then initX else putStrLn "could not find xcape binary"
where
initX = do
-- ignore SIGCHLD so we don't produce zombie processes
void $ installHandler sigCHLD Ignore Nothing
withDisplay $ \dpy -> do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
let cf =
XMConf
let cf = XMConf
{ display = dpy
, theRoot = root
, netActiveWindow = naw
@ -132,18 +136,12 @@ initXMan rs cp = do
allocaSetWindowAttributes $ \a -> do
set_event_mask a propertyChangeMask
changeWindowAttributes dpy root cWEventMask a
allocaXEvent $ \e ->
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 :: MonadUnliftIO m => (Display -> m a) -> m a
withDisplay = bracket (liftIO $ openDisplay "") cleanup
where
cleanup dpy = liftIO $ do
flush dpy
closeDisplay dpy
-- | Return true if xcape is installed
checkXcape :: IO Bool
checkXcape = isJust <$> findExecutable xcapeExe
@ -152,8 +150,8 @@ 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 ()
runXMan c s (XMan a) = void $ runStateT (runReaderT a c) s
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
runXMan c s (XMan a) = runStateT (runReaderT a c) s
-- | Update the xcape status given the state of XMan
updateXCape :: XMan ()
@ -179,9 +177,8 @@ 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
@ -200,7 +197,7 @@ permitBadWindow action = do
-- TODO also ignore badvalue errors?
handleError ErrorEvent { ev_error_code = t }
| 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
-- regular expressions in XMan
@ -217,7 +214,7 @@ startXCape = do
cp <- asks xcapeProcess
h <- io $ createProcessNull cp
modify $ \s -> s { xcapeHandle = Just h }
io $ TI.putStrLn "started xcape"
io $ print "started xcape"
-- | Stop xcape if it is running
stopXCape :: XMan ()
@ -226,7 +223,7 @@ stopXCape = do
forM_ pID $ \p -> do
io $ terminateProcess p
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
-- redirected to the null device

View File

@ -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

View File

@ -1,5 +0,0 @@
libxcb
libxrender
libxrandr
libxss
libxext

View File

@ -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

View File

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-20.11
resolver: lts-16.31
# User packages to be built.
# 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
# compiler-check: newer-minor
nix:
enable: true
packages:
- xorg.libxcb
- xorg.libXrender
- xorg.libXrandr
- xorg.libXScrnSaver
- xorg.libXext

38
xman.cabal Normal file
View File

@ -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