From 6b3cfd58570f2bb2374518f1e21545f4b2c26364 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 1 Jan 2023 15:00:40 -0500 Subject: [PATCH] REF use better naming for RIO monad --- bin/xmobar.hs | 16 +++--- bin/xmonad.hs | 30 +++++------ lib/Data/Internal/Dependency.hs | 70 +++++++++++++------------- lib/XMonad/Internal/Command/Desktop.hs | 2 +- lib/XMonad/Internal/Command/Power.hs | 2 +- lib/XMonad/Internal/DBus/Control.hs | 6 +-- 6 files changed, 63 insertions(+), 63 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index e7fa370..fe6f300 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 7e7a4a4..e1708bc 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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 diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index a28f84d..d90feea 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index d678eb0..1aef07a 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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" diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 70b9c12..adc5477 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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 = diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 584a618..846c13d 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -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