REF clean up concurrency libs

This commit is contained in:
Nathan Dwarshuis 2022-12-28 20:11:06 -05:00
parent e3e89c2754
commit f5ee8882bc
5 changed files with 38 additions and 37 deletions

View File

@ -9,18 +9,13 @@ module XMonad.Internal.Concurrent.ACPIEvent
, runHandleACPI , runHandleACPI
) where ) where
import Control.Exception
import Control.Monad
import Data.ByteString hiding (readFile)
import Data.ByteString.Char8 as C hiding (readFile)
import Data.Connection
import Data.Internal.Dependency import Data.Internal.Dependency
import Text.Read (readMaybe) import Network.Socket
import Network.Socket.ByteString
import System.IO.Streams as S (read) import RIO
import System.IO.Streams.UnixSocket import qualified RIO.ByteString as B
import XMonad.Core import XMonad.Core
import XMonad.Internal.Command.Power import XMonad.Internal.Command.Power
@ -64,7 +59,9 @@ parseLine line =
(_:"LID":"close":_) -> Just LidClose (_:"LID":"close":_) -> Just LidClose
_ -> Nothing _ -> Nothing
where where
splitLine = C.words . C.reverse . C.dropWhile (== '\n') . C.reverse splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
newline = 10
space = 32
-- | Send an ACPIEvent to the X server as a ClientMessage -- | Send an ACPIEvent to the X server as a ClientMessage
sendACPIEvent :: ACPIEvent -> IO () sendACPIEvent :: ACPIEvent -> IO ()
@ -72,20 +69,18 @@ sendACPIEvent = sendXMsg ACPI . show . fromEnum
isDischarging :: IO (Maybe Bool) isDischarging :: IO (Maybe Bool)
isDischarging = do isDischarging = do
status <- try $ readFile "/sys/class/power_supply/BAT0/status" status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
:: IO (Either IOException String)
case status of case status of
Left _ -> return Nothing Left _ -> return Nothing
Right s -> return $ Just (s == "Discharging") Right s -> return $ Just (s == "Discharging")
listenACPI :: IO () listenACPI :: IO ()
listenACPI = do listenACPI = do
Connection { source = s } <- connect acpiPath sock <- socket AF_UNIX Stream defaultProtocol
forever $ readStream s connect sock $ SockAddrUnix acpiPath
where forever $ do
readStream s = do out <- recv sock 1024
out <- S.read s mapM_ sendACPIEvent $ parseLine out
mapM_ sendACPIEvent $ parseLine =<< out
acpiPath :: FilePath acpiPath :: FilePath
acpiPath = "/var/run/acpid.socket" acpiPath = "/var/run/acpid.socket"

View File

@ -28,6 +28,9 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Data structure for the ClientMessage -- | Data structure for the ClientMessage
@ -58,13 +61,19 @@ splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "") splitXMsg [] = (Unknown, "")
splitXMsg (x:xs) = (xtype, tag) splitXMsg (x:xs) = (xtype, tag)
where where
xtype = toEnum $ fromInteger $ toInteger x xtype = toEnum $ fromIntegral x
tag = map (chr . fromInteger . toInteger) $ takeWhile (/= 0) xs tag = chr . fromIntegral <$> takeWhile (/= 0) xs
withOpenDisplay :: (Display -> IO a) -> IO a
withOpenDisplay = bracket (openDisplay "") cleanup
where
cleanup dpy = do
flush dpy
closeDisplay dpy
-- | Emit a ClientMessage event to the X server with the given type and payloud -- | Emit a ClientMessage event to the X server with the given type and payloud
sendXMsg :: XMsgType -> String -> IO () sendXMsg :: XMsgType -> String -> IO ()
sendXMsg xtype tag = do sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
dpy <- openDisplay ""
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
allocaXEvent $ \e -> do allocaXEvent $ \e -> do
setEventType e clientMessage setEventType e clientMessage
@ -84,8 +93,6 @@ sendXMsg xtype tag = do
-- for more details. -- for more details.
setClientMessageEvent' e root bITMAP 8 (x:t) setClientMessageEvent' e root bITMAP 8 (x:t)
sendEvent dpy root False substructureNotifyMask e sendEvent dpy root False substructureNotifyMask e
flush dpy
closeDisplay dpy
where where
x = fromIntegral $ fromEnum xtype x = fromIntegral $ fromEnum xtype
t = fmap (fromIntegral . fromEnum) tag t = fmap (fromIntegral . fromEnum) tag

View File

@ -41,11 +41,6 @@ import Data.Maybe
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import RIO hiding
( Display
, display
)
import qualified RIO.Set as S
import Graphics.X11.Types import Graphics.X11.Types
@ -56,6 +51,12 @@ import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Types import Graphics.X11.Xlib.Types
import RIO hiding
( Display
, display
)
import qualified RIO.Set as S
import XMonad.Actions.DynamicWorkspaces import XMonad.Actions.DynamicWorkspaces
import XMonad.Core import XMonad.Core
( ManageHook ( ManageHook
@ -103,11 +104,11 @@ data WConf = WConf
type W a = RIO WConf () type W a = RIO WConf ()
withDisplay :: (Display -> IO a) -> IO a withOpenDisplay :: (Display -> IO a) -> IO a
withDisplay = bracket (openDisplay "") closeDisplay withOpenDisplay = bracket (openDisplay "") closeDisplay
runWorkspaceMon :: [DynWorkspace] -> IO () runWorkspaceMon :: [DynWorkspace] -> IO ()
runWorkspaceMon dws = withDisplay $ \dpy -> do runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
root <- rootWindow dpy $ defaultScreen dpy root <- rootWindow dpy $ defaultScreen dpy
-- listen only for substructure change events (which includes MapNotify) -- listen only for substructure change events (which includes MapNotify)
allocaSetWindowAttributes $ \a -> do allocaSetWindowAttributes $ \a -> do

View File

@ -10,18 +10,15 @@ module XMonad.Internal.Concurrent.VirtualBox
, qual , qual
) where ) where
import Control.Exception
import Data.Internal.Dependency import Data.Internal.Dependency
import Text.XML.Light import Text.XML.Light
import RIO hiding (try) import RIO hiding (try)
import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory
import XMonad.Internal.Shell import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg) vmExists :: T.Text -> IO (Maybe Msg)
@ -41,7 +38,7 @@ vmInstanceConfig vmName = do
vmDirectory :: IO (Either String String) vmDirectory :: IO (Either String String)
vmDirectory = do vmDirectory = do
p <- vmConfig p <- vmConfig
(s :: Either IOException String) <- try $ readFile p s <- tryIO $ readFile p
return $ case s of return $ case s of
(Left _) -> Left "could not read VirtualBox config file" (Left _) -> Left "could not read VirtualBox config file"
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right

View File

@ -42,6 +42,7 @@ dependencies:
- lifted-base >= 0.2.3.12 - lifted-base >= 0.2.3.12
- utf8-string >= 1.0.2 - utf8-string >= 1.0.2
- typed-process >= 0.2.8.0 - typed-process >= 0.2.8.0
- network >= 3.1.2.7
library: library:
source-dirs: lib/ source-dirs: lib/