REF use better naming for RIO monad

This commit is contained in:
Nathan Dwarshuis 2023-01-01 15:00:40 -05:00
parent 00f899ed9a
commit 6b3cfd5857
6 changed files with 63 additions and 63 deletions

View File

@ -65,13 +65,13 @@ parseTest =
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = withCache $
xio o = runXIO $
case o of
XDeps -> printDeps
XTest -> withDBus_ evalConfig
XRun -> run
run :: FIO ()
run :: XIO ()
run = do
-- IDK why this is needed, I thought this was default
liftIO $ hSetBuffering stdout LineBuffering
@ -79,7 +79,7 @@ run = do
c <- evalConfig db
liftIO $ xmobar c
evalConfig :: DBusState -> FIO Config
evalConfig :: DBusState -> XIO Config
evalConfig db = do
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
@ -87,7 +87,7 @@ evalConfig db = do
d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d
printDeps :: FIO ()
printDeps :: XIO ()
printDeps = withDBus_ $ \db ->
mapM_ logInfo $
fmap showFulfillment $
@ -186,7 +186,7 @@ getAllCommands right =
, brRight = catMaybes right
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
rightPlugins db =
mapM evalFeature $
allFeatures db
@ -523,7 +523,7 @@ dateCmd =
--------------------------------------------------------------------------------
-- low-level testing functions
vpnPresent :: FIO (Maybe Msg)
vpnPresent :: XIO (Maybe Msg)
vpnPresent = do
res <- proc "nmcli" args readProcess
return $ case res of
@ -549,7 +549,7 @@ vpnPresent = do
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.
getTextFont :: FIO T.Text
getTextFont :: XIO T.Text
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
@ -557,7 +557,7 @@ getTextFont = do
--------------------------------------------------------------------------------
-- icon fonts
getIconFonts :: FIO ([T.Text], [Int])
getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb

View File

@ -91,13 +91,13 @@ parseTest =
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = withCache $
xio o = runXIO $
case o of
XDeps -> printDeps
XTest -> undefined
XRun -> run
run :: FIO ()
run :: XIO ()
run = do
-- These first two commands are only significant when xmonad is restarted.
-- The 'launch' function below this will turn off buffering (so flushes are
@ -172,10 +172,10 @@ getCreateDirectories = do
data FeatureSet = FeatureSet
{ fsKeys :: X () -> DBusState -> [KeyGroup FeatureX]
, fsDBusExporters :: [Maybe SesClient -> Sometimes (FIO (), FIO ())]
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
, fsPowerMon :: SometimesIO
, fsRemovableMon :: Maybe SysClient -> SometimesIO
, fsDaemons :: [Sometimes (FIO (Process () () ()))]
, fsDaemons :: [Sometimes (XIO (Process () () ()))]
, fsACPIHandler :: Always (String -> X ())
, fsTabbedTheme :: Always Theme
, fsDynWorkspaces :: [Sometimes DynWorkspace]
@ -203,10 +203,10 @@ features cl =
, fsDaemons = [runNetAppDaemon cl, runAutolock]
}
withXmobar :: (Process Handle () () -> FIO a) -> FIO a
withXmobar :: (Process Handle () () -> XIO a) -> XIO a
withXmobar = bracket startXmobar stopXmobar
startXmobar :: FIO (Process Handle () ())
startXmobar :: XIO (Process Handle () ())
startXmobar = do
logInfo "starting xmobar child process"
p <- proc "xmobar" [] start
@ -228,11 +228,11 @@ stopXmobar p = do
withChildDaemons
:: FeatureSet
-> ([(Utf8Builder, Process () () ())] -> FIO a)
-> FIO a
-> ([(Utf8Builder, Process () () ())] -> XIO a)
-> XIO a
withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
startChildDaemons :: FeatureSet -> FIO [(Utf8Builder, Process () () ())]
startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
where
start s@(Sometimes sname _ _) = do
@ -256,7 +256,7 @@ stopChildDaemons = mapM_ stop
logInfo $ "stopping child process: " <> n
liftIO $ killNoWait p
printDeps :: FIO ()
printDeps :: XIO ()
printDeps = withDBus_ $ \db -> do
runIO <- askRunInIO
let mockCleanup = runCleanup runIO mockClean db
@ -265,7 +265,7 @@ printDeps = withDBus_ $ \db -> do
externalBindings mockCleanup db
let dbus =
fmap (\f -> f $ dbSesClient db) dbusExporters
:: [Sometimes (FIO (), FIO ())]
:: [Sometimes (XIO (), XIO ())]
let others = [runRemovableMon $ dbSysClient db, runPowermon]
-- TODO might be better to use glog for this?
mapM_ logInfo $
@ -286,11 +286,11 @@ printDeps = withDBus_ $ \db -> do
data Cleanup = Cleanup
{ clChildren :: [(Utf8Builder, Process () () ())]
, clXmobar :: Maybe (Process Handle () ())
, clDBusUnexporters :: [FIO ()]
, clDBusUnexporters :: [XIO ()]
}
runCleanup
:: (FIO () -> IO ())
:: (XIO () -> IO ())
-> Cleanup
-> DBusState
-> X ()
@ -773,13 +773,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a]
}
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
evalExternal = mapM go
where
go k@KeyGroup {kgBindings = bs} =
(\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k {kbMaybeAction = f}) <$> evalFeature a

View File

@ -53,8 +53,8 @@ module Data.Internal.Dependency
, dumpSometimes
, showFulfillment
-- testing
, FIO
, withCache
, XIO
, runXIO
, evalFeature
, executeSometimes
, executeAlways
@ -128,8 +128,8 @@ import XMonad.Internal.Theme
-- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a
withCache x = do
runXIO :: XIO a -> IO a
runXIO x = do
logOpts <- logOptionsHandle stderr False
pc <- mkDefaultProcessContext
withLogFunc logOpts $ \f -> do
@ -138,20 +138,20 @@ withCache x = do
runRIO s x
-- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a
executeAlways :: Always (IO a) -> XIO a
executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> FIO (Maybe a)
evalFeature :: Feature a -> XIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes :: Sometimes a -> XIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
goPass (a, ws) = putErrors ws >> return (Just a)
@ -159,13 +159,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
putErrors = mapM_ logMsg
-- | Return the action of an Always
evalAlways :: Always a -> FIO a
evalAlways :: Always a -> XIO a
evalAlways a = do
(x, ws) <- evalAlwaysMsg a
mapM_ logMsg ws
return x
logMsg :: FMsg -> FIO ()
logMsg :: FMsg -> XIO ()
logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@ -210,7 +210,7 @@ type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (FIO ())
type SometimesIO = Sometimes (XIO ())
type Feature a = Either (Sometimes a) (Always a)
@ -290,7 +290,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | A dependency that only requires IO to evaluate (with payload)
data IODependency p
= -- an IO action that yields a payload
IORead T.Text [Fulfillment] (FIO (Result p))
IORead T.Text [Fulfillment] (XIO (Result p))
| -- always yields a payload
IOConst p
| -- an always that yields a payload
@ -308,7 +308,7 @@ data DBusDependency_ c
-- | A dependency that only requires IO to evaluate (no payload)
data IODependency_
= IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency
@ -377,7 +377,7 @@ data PostFail = PostFail [Msg] | PostMissing Msg
--------------------------------------------------------------------------------
-- Configuration
type FIO a = RIO DepStage a
type XIO a = RIO DepStage a
data DepStage = DepStage
{ dsLogFun :: !LogFunc
@ -508,7 +508,7 @@ infix 9 .:+
--------------------------------------------------------------------------------
-- Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . dsParams)
if not r
@ -522,7 +522,7 @@ evalSometimesMsg (Sometimes n u xs) = do
where
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do
r <- testAlways x
return $ case r of
@ -542,7 +542,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
where
f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> FIO (PostAlways a)
testAlways :: Always_ a -> XIO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
@ -552,18 +552,18 @@ testAlways = go []
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> FIO a
evalFallbackRoot :: FallbackRoot a -> XIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> FIO p
evalFallbackStack :: FallbackStack p -> XIO p
evalFallbackStack (FallbackBottom a) = evalAlways a
evalFallbackStack (FallbackStack f a as) = do
ps <- evalFallbackStack as
p <- evalAlways a
return $ f p ps
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
@ -573,13 +573,13 @@ testSometimes = go (PostSometimes Nothing [])
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature sf@Subfeature {sfData = t} = do
t' <- testRoot t
-- monomorphism restriction :(
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot :: Root a -> XIO (Either PostFail (PostPass a))
testRoot r = do
case r of
(IORoot a t) -> go a testIODep_ testIODep t
@ -593,7 +593,7 @@ testRoot r = do
Msg LevelError "client not available"
where
-- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
@ -606,13 +606,13 @@ type MResult p = Memoized (Result p)
testTree
:: forall d d_ p
. (d_ -> FIO MResult_)
-> (forall q. d q -> FIO (MResult q))
. (d_ -> XIO MResult_)
-> (forall q. d q -> XIO (MResult q))
-> Tree d d_ p
-> FIO (Either [Msg] (PostPass p))
-> XIO (Either [Msg] (PostPass p))
testTree test_ test = go
where
go :: forall q. Tree d d_ q -> FIO (Result q)
go :: forall q. Tree d d_ q -> XIO (Result q)
go (And12 f a b) = do
ra <- go a
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -629,7 +629,7 @@ testTree test_ test = go
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
liftRight = either (return . Left)
testIODep :: IODependency p -> FIO (MResult p)
testIODep :: IODependency p -> XIO (MResult p)
testIODep d = memoizeMVar $ case d of
IORead _ _ t -> t
IOConst c -> return $ Right $ PostPass c []
@ -657,7 +657,7 @@ type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
testTree_ test = go
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -665,10 +665,10 @@ testTree_ test = go
go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODep_ :: IODependency_ -> FIO MResult_
testIODep_ :: IODependency_ -> XIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ :: IODependency_ -> XIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) =
@ -763,7 +763,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
fontTestName :: T.Text -> T.Text
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
-- testFont :: T.Text -> FIO (Result FontBuilder)
-- testFont :: T.Text -> XIO (Result FontBuilder)
-- testFont = liftIO . testFont'
testFont
@ -821,7 +821,7 @@ readInterface n f = IORead n [] go
--------------------------------------------------------------------------------
-- Misc testers
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
socketExists n ful =
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
@ -845,10 +845,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of

View File

@ -264,7 +264,7 @@ runNotificationContext =
-- System commands
-- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
runNetAppDaemon cl =
Sometimes
"network applet"

View File

@ -84,7 +84,7 @@ runReboot = spawn "systemctl reboot"
--------------------------------------------------------------------------------
-- Autolock
runAutolock :: Sometimes (FIO (P.Process () () ()))
runAutolock :: Sometimes (XIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where
tree =

View File

@ -102,9 +102,9 @@ disconnectDBusX db = do
withDBusInterfaces
:: DBusState
-> [Maybe SesClient -> Sometimes (FIO (), FIO ())]
-> ([FIO ()] -> FIO a)
-> FIO a
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
-> ([XIO ()] -> XIO a)
-> XIO a
withDBusInterfaces db interfaces = bracket up sequence
where
up = do