REF use rio and such

.gitignore

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

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

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

make_pkgs

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

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

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.

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
-