REF use better naming for RIO monad
This commit is contained in:
parent
00f899ed9a
commit
6b3cfd5857
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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 =
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue