From 7eacd0134fde0f81f56fd2eaf1a348b0c3e63bb6 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 13 Feb 2023 21:40:26 -0500 Subject: [PATCH] REF use rio and such --- .gitignore | 1 + app/Main.hs | 164 +++++++++++++++++++++++++------------------------- fourmolu.yaml | 14 +++++ package.yaml | 80 ++++++++++++++++++++++++ stack.yaml | 2 +- xman.cabal | 38 ------------ 6 files changed, 179 insertions(+), 120 deletions(-) create mode 100644 fourmolu.yaml create mode 100644 package.yaml delete mode 100644 xman.cabal diff --git a/.gitignore b/.gitignore index b05a046..ad65818 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .stack-work/ stack.yaml.lock TAGS +xman.cabal *~ diff --git a/app/Main.hs b/app/Main.hs index cca8111..6884700 100644 --- a/app/Main.hs +++ b/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 diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..190e1ca --- /dev/null +++ b/fourmolu.yaml @@ -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 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..727aa6e --- /dev/null +++ b/package.yaml @@ -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 + +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 diff --git a/stack.yaml b/stack.yaml index f5b329d..db201ed 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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. diff --git a/xman.cabal b/xman.cabal deleted file mode 100644 index 5ff4e5b..0000000 --- a/xman.cabal +++ /dev/null @@ -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 -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 -