ENH use nix

.gitignore

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

app/Main.hs

@@ -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,51 +25,52 @@
 
 module Main (main) where
 
-import qualified Data.Text.IO as TI
+import           Control.Monad
-import Graphics.X11.Types
+import           Control.Monad.Reader
-import Graphics.X11.Xlib.Atom
+import           Control.Monad.State
-import Graphics.X11.Xlib.Display
+
-import Graphics.X11.Xlib.Event
+import           Data.Maybe                (isJust)
-import Graphics.X11.Xlib.Extras
+
-import Graphics.X11.Xlib.Misc
+import           Graphics.X11.Types
-import Graphics.X11.Xlib.Types
+import           Graphics.X11.Xlib.Atom
-import RIO hiding (Display, display, handle)
+import           Graphics.X11.Xlib.Display
-import RIO.Directory
+import           Graphics.X11.Xlib.Event
-import RIO.State
+import           Graphics.X11.Xlib.Extras
-import System.Environment
+import           Graphics.X11.Xlib.Misc
-import System.Posix.IO
+import           Graphics.X11.Xlib.Types
-import System.Posix.Signals
+
-import System.Process
+import           Text.Regex.TDFA
-import Text.Regex.TDFA
+
+import           System.Directory
+import           System.Environment
+import           System.Posix.IO
+import           System.Posix.Signals
+import           System.Process
 
 --------------------------------------------------------------------------------
--- 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)
+instance Applicative XMan where
-  deriving
+  pure = return
-    ( Functor
+  (<*>) = ap
-    , Applicative
-    , Monad
-    , MonadIO
-    , MonadState XMState
-    , MonadReader XMConf
-    )
 
-newtype XMState = XMState {xcapeHandle :: Maybe ProcessHandle}
+newtype XMState = XMState { xcapeHandle :: Maybe ProcessHandle }
 
 data XMConf = XMConf
-  { display :: Display
+    { display         :: Display
-  , theRoot :: Window
+    , theRoot         :: Window
-  , netActiveWindow :: Atom
+    , netActiveWindow :: Atom
-  , regexps :: Patterns
+    , regexps         :: Patterns
-  , xcapeProcess :: CreateProcess
+    , xcapeProcess    :: CreateProcess
-  }
+    }
 
 -- | timeout for xcape
 type Timeout = Maybe String
@@ -87,11 +91,12 @@ main = getArgs >>= parse
 
 -- | Given a list of arguments, either start the program or print the usage
 parse :: [String] -> IO ()
-parse [_] = usage
+parse [_]           = usage
-parse ("-t" : t : b : rs) = initXMan rs $ mkXcapeProcess (Just t) b
+parse ("-t":t:b:rs) = initXMan rs $ mkXcapeProcess (Just t) b
-parse (b : rs) = initXMan rs $ mkXcapeProcess Nothing b
+parse (b:rs)        = initXMan rs $ mkXcapeProcess Nothing b
-parse _ = usage
+parse _             = usage
 
+-- | The name of the xcape executable
 xcapeExe :: String
 xcapeExe = "xcape"
 
@@ -99,51 +104,44 @@ 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 (Just t) b =  proc xcapeExe $ ["-t", t, "-d", "-e"] ++ [b]
-mkXcapeProcess Nothing b = proc xcapeExe $ ["-d", "-e"] ++ [b]
+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
+      root <- rootWindow dpy $ defaultScreen dpy
-        naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
+      naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
-        let cf =
+      let cf = XMConf
-              XMConf
+                 { display = dpy
-                { display = dpy
+                 , theRoot = root
-                , theRoot = root
+                 , netActiveWindow = naw
-                , netActiveWindow = naw
+                 , regexps = rs
-                , regexps = rs
+                 , xcapeProcess = cp
-                , xcapeProcess = cp
+                 }
-                }
+          st = XMState { xcapeHandle = Nothing }
-            st = XMState {xcapeHandle = Nothing}
+      -- listen only for PropertyNotify events on the root window
-        -- listen only for PropertyNotify events on the root window
+      allocaSetWindowAttributes $ \a -> do
-        allocaSetWindowAttributes $ \a -> do
+        set_event_mask a propertyChangeMask
-          set_event_mask a propertyChangeMask
+        changeWindowAttributes dpy root cWEventMask a
-          changeWindowAttributes dpy root cWEventMask a
+      void $ allocaXEvent $ \e ->
-        allocaXEvent $ \e ->
+        runXMan cf st $ do
-          runXMan cf st $ do
+          updateXCape -- set the initial state before entering main loop
-            updateXCape -- set the initial state before entering main loop
+          forever $ handle =<< io (nextEvent dpy e >> getEvent e)
-            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 :: XMConf -> XMState -> XMan a -> IO (a, XMState)
-runXMan c s (XMan a) = void $ runStateT (runReaderT a c) s
+runXMan c s (XMan a) = runStateT (runReaderT a c) s
 
 -- | Update the xcape status given the state of XMan
 updateXCape :: XMan ()
@@ -166,22 +164,21 @@ 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 =
+getAppName w = io . fmap resName . permitBadWindow . flip getClassHint w =<<
-  io . fmap resName . permitBadWindow . flip getClassHint w
+  asks display
-    =<< 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,9 +195,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 _ = 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
@@ -216,8 +213,8 @@ startXCape = do
   unless (isJust pID) $ do
     cp <- asks xcapeProcess
     h <- io $ createProcessNull cp
-    modify $ \s -> s {xcapeHandle = Just h}
+    modify $ \s -> s { xcapeHandle = Just h }
-    io $ TI.putStrLn "started xcape"
+    io $ print "started xcape"
 
 -- | Stop xcape if it is running
 stopXCape :: XMan ()
@@ -225,8 +222,8 @@ stopXCape = do
   pID <- gets xcapeHandle
   forM_ pID $ \p -> do
     io $ terminateProcess p
-    modify $ \s -> s {xcapeHandle = Nothing}
+    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
@@ -237,5 +234,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

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

make_pkgs

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

package.yaml

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

stack.yaml

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

xman.cabal

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