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

1
.gitignore vendored
View File

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

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
-- for making custom keymaps. However, it is not always desirable to have this
@ -25,13 +22,7 @@
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 qualified Data.Text.IO as TI
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
@ -39,29 +30,33 @@ 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 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}
@ -109,22 +104,23 @@ 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 ""
withDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
let cf = XMConf
let cf =
XMConf
{ display = dpy
, theRoot = root
, netActiveWindow = naw
@ -136,23 +132,28 @@ initXMan rs cp = do
allocaSetWindowAttributes $ \a -> do
set_event_mask a propertyChangeMask
changeWindowAttributes dpy root cWEventMask a
void $ allocaXEvent $ \e ->
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 ()
@ -178,8 +179,9 @@ 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
@ -198,7 +200,7 @@ permitBadWindow action = do
-- TODO also ignore badvalue errors?
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
@ -215,7 +217,7 @@ startXCape = do
cp <- asks xcapeProcess
h <- io $ createProcessNull cp
modify $ \s -> s {xcapeHandle = Just h}
io $ print "started xcape"
io $ TI.putStrLn "started xcape"
-- | Stop xcape if it is running
stopXCape :: XMan ()
@ -224,7 +226,7 @@ stopXCape = do
forM_ pID $ \p -> do
io $ terminateProcess p
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
-- redirected to the null device

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

View File

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

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