xmonad-config/lib/XMonad/Internal/IO.hs

--------------------------------------------------------------------------------
-- Random IO-ish functions used throughtout xmonad
--
-- Most (probably all) of these functions are intended to work with sysfs where
-- some safe assumptions can be made about file contents.

module XMonad.Internal.IO
  ( readInt
  , readBool
  , readPercent
  , writeInt
  , writeBool
  , writePercent
  , writePercentMin
  , writePercentMax
  , decPercent
  , incPercent
  -- , isReadable
  -- , isWritable
  , PermResult (..)
  , getPermissionsSafe
  , waitUntilExit
  , withOpenDisplay
  )
where

import Data.Char
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
import RIO.Directory
import RIO.FilePath
import qualified RIO.Text as T
import System.IO.Error
import System.Process

--------------------------------------------------------------------------------
-- read

readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8

readBool :: MonadIO m => FilePath -> m Bool
readBool = fmap (== (1 :: Int)) . readInt

--------------------------------------------------------------------------------
-- write

writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
writeInt f = writeFileUtf8 f . T.pack . show

writeBool :: MonadIO m => FilePath -> Bool -> m ()
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)

--------------------------------------------------------------------------------
-- percent-based read/write
--
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
-- value. Assume that the file being read has a min of 0 and an unchanging max
-- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent).
rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw =
  100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)

-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper

readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
readPercent bounds path = do
  i <- readInt path
  return $ rawToPercent bounds (i :: Integer)

percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
percentToRaw (lower, upper) perc =
  round $
    fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)

writePercent
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> b
  -> m b
writePercent bounds path perc = do
  let t
        | perc > 100 = 100
        | perc < 0 = 0
        | otherwise = perc
  writeInt path (percentToRaw bounds t :: Int)
  return t

writePercentMin
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> m b
writePercentMin bounds path = writePercent bounds path 0

writePercentMax
  :: (MonadIO m, Integral a, RealFrac b)
  => (a, a)
  -> FilePath
  -> m b
writePercentMax bounds path = writePercent bounds path 100

shiftPercent
  :: (MonadIO m, Integral a, RealFrac b)
  => (b -> b -> b)
  -> Int
  -> FilePath
  -> (a, a)
  -> m b
shiftPercent f steps path bounds =
  writePercent bounds path . f stepsize
    =<< readPercent bounds path
  where
    stepsize = 100 / fromIntegral steps

incPercent
  :: (MonadIO m, Integral a, RealFrac b)
  => Int
  -> FilePath
  -> (a, a)
  -> m b
incPercent = shiftPercent (+)

decPercent
  :: (MonadIO m, Integral a, RealFrac b)
  => Int
  -> FilePath
  -> (a, a)
  -> m b
decPercent = shiftPercent subtract -- silly (-) operator thingy error

--------------------------------------------------------------------------------
-- permission query

data PermResult a = PermResult a | NotFoundError | PermError
  deriving (Show, Eq)

-- instance Functor PermResult where
--   fmap f (PermResult r) = PermResult $ f r
--   fmap _ NotFoundError  = NotFoundError
--   fmap _ PermError      = PermError

getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
getPermissionsSafe f = do
  r <- tryIO $ getPermissions f
  return $ case r of
    Right z -> PermResult z
    Left (isPermissionError -> True) -> PermError
    Left (isDoesNotExistError -> True) -> NotFoundError
    -- the above error should be the only ones thrown by getPermission,
    -- so the catchall case should never happen
    _ -> error "Unknown permission error"

-- isReadable :: FilePath -> IO (PermResult Bool)
-- isReadable = fmap (fmap readable) . getPermissionsSafe

-- isWritable :: FilePath -> IO (PermResult Bool)
-- isWritable = fmap (fmap writable) . getPermissionsSafe

-- | Block until a PID has exited.
-- Use this to control flow based on a process that was not explicitly started
-- by the Haskell runtime itself, and thus has no data structures to query.
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
waitUntilExit pid = do
  res <- doesDirectoryExist $ "/proc" </> show pid
  when res $ do
    threadDelay 100000
    waitUntilExit pid

withOpenDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
withOpenDisplay = bracket (liftIO $ openDisplay "") cleanup
  where
    cleanup dpy = liftIO $ do
      flush dpy
      closeDisplay dpy