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
|
||||
*~
|
||||
|
|
|
|||
72
app/Main.hs
72
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,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
|
||||
|
|
|
|||
|
|
@ -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