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

View File

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

View File

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

View File

@ -264,7 +264,7 @@ runNotificationContext =
-- System commands -- System commands
-- this is required for some vpn's to work properly with network-manager -- 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 = runNetAppDaemon cl =
Sometimes Sometimes
"network applet" "network applet"

View File

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

View File

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