ENH use rio process for deps
This commit is contained in:
parent
23956e063b
commit
6526f5e309
|
|
@ -214,14 +214,14 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
|||
where
|
||||
root useIcon = IORoot_ (batteryCmd useIcon)
|
||||
tree = Only_ $ IOTest_ "Test if battery is present" []
|
||||
$ fmap (Msg LevelError) <$> hasBattery
|
||||
$ io $ fmap (Msg LevelError) <$> hasBattery
|
||||
|
||||
getVPN :: Maybe SysClient -> BarFeature
|
||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||
where
|
||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
|
||||
networkManagerPkgs vpnPresent
|
||||
networkManagerPkgs $ io vpnPresent
|
||||
|
||||
getBt :: Maybe SysClient -> BarFeature
|
||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||
|
|
|
|||
|
|
@ -79,7 +79,6 @@ parse ["--deps"] = withCache printDeps
|
|||
parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
|
||||
parse _ = usage
|
||||
|
||||
|
||||
run :: IO ()
|
||||
run = do
|
||||
-- These first two commands are only significant when xmonad is restarted.
|
||||
|
|
@ -150,38 +149,17 @@ features cl = FeatureSet
|
|||
evalConf db@DBusState { dbSysClient = cl } = do
|
||||
-- start DBus interfaces first since many features after this test these
|
||||
-- interfaces as dependencies
|
||||
io $ putStrLn "hi"
|
||||
-- io $ hFlush stdout
|
||||
let fs = features cl
|
||||
tt <- evalAlways $ fsTabbedTheme fs
|
||||
io $ putStrLn "tabbed theme started"
|
||||
-- io $ hFlush stdout
|
||||
-- io $ print =<< readCreateProcessWithExitCode (proc "echo" ["hi"]) ""
|
||||
startDBusInterfaces fs
|
||||
io $ putStrLn "dbus started"
|
||||
-- io $ hFlush stdout
|
||||
(xmobarHandle, ts) <- startChildDaemons fs
|
||||
io $ putStrLn "child daemons started"
|
||||
-- io $ hFlush stdout
|
||||
startRemovableMon fs
|
||||
io $ putStrLn "removemon started"
|
||||
-- io $ hFlush stdout
|
||||
startPowerMon fs
|
||||
io $ putStrLn "powermon started"
|
||||
-- io $ hFlush stdout
|
||||
dws <- startDynWorkspaces fs
|
||||
io $ putStrLn "dyn workspace started"
|
||||
-- io $ hFlush stdout
|
||||
-- fb <- evalAlways $ fsFontBuilder features
|
||||
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
|
||||
io $ putStrLn "keys started"
|
||||
-- io $ hFlush stdout
|
||||
sk <- evalAlways $ fsShowKeys fs
|
||||
io $ putStrLn "showkeys started"
|
||||
-- io $ hFlush stdout
|
||||
ha <- evalAlways $ fsACPIHandler fs
|
||||
io $ putStrLn "acpi handler started"
|
||||
-- io $ hFlush stdout
|
||||
return $ ewmh
|
||||
$ addKeymap dws sk kbs
|
||||
$ docks
|
||||
|
|
@ -207,9 +185,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
|
|||
io $ case h of
|
||||
Just h' -> hSetBuffering h' LineBuffering
|
||||
Nothing -> return ()
|
||||
--installSignalHandlers
|
||||
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||
-- uninstallSignalHandlers
|
||||
return (h, ThreadState (p:ps) $ maybeToList h)
|
||||
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
|
||||
$ dbSysClient db
|
||||
|
|
@ -315,7 +291,7 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
|
|||
[Subfeature root "windows 8 VM"]
|
||||
where
|
||||
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
|
||||
$ IOTest_ name [] $ vmExists vm
|
||||
$ IOTest_ name [] $ io $ vmExists vm
|
||||
name = T.unwords ["test if", vm, "exists"]
|
||||
c = "VirtualBoxVM"
|
||||
vm = "win8raw"
|
||||
|
|
|
|||
|
|
@ -126,6 +126,7 @@ import qualified DBus.Introspection as I
|
|||
|
||||
import RIO hiding (bracket, fromString)
|
||||
import RIO.FilePath
|
||||
import RIO.Process hiding (findExecutable)
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
|
|
@ -135,7 +136,6 @@ import System.Posix.Files
|
|||
|
||||
import XMonad.Core (X, io)
|
||||
import XMonad.Internal.IO
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Internal.Theme
|
||||
|
||||
|
|
@ -150,9 +150,10 @@ import XMonad.Internal.Theme
|
|||
withCache :: FIO a -> IO a
|
||||
withCache x = do
|
||||
logOpts <- logOptionsHandle stderr False
|
||||
pc <- mkDefaultProcessContext
|
||||
withLogFunc logOpts $ \f -> do
|
||||
p <- getParams
|
||||
let s = DepStage f p
|
||||
let s = DepStage f pc p
|
||||
runRIO s x
|
||||
|
||||
-- | Execute an Always immediately
|
||||
|
|
@ -315,7 +316,7 @@ data DBusDependency_ c = Bus [Fulfillment] BusName
|
|||
|
||||
-- | A dependency that only requires IO to evaluate (no payload)
|
||||
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
||||
| IOTest_ T.Text [Fulfillment] (IO (Maybe Msg))
|
||||
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
|
||||
| forall a. IOSometimes_ (Sometimes a)
|
||||
|
||||
-- | A system component to an IODependency
|
||||
|
|
@ -386,12 +387,15 @@ type FIO a = RIO DepStage a
|
|||
|
||||
data DepStage = DepStage
|
||||
{ dsLogFun :: !LogFunc
|
||||
, dsProcCxt :: !ProcessContext
|
||||
, dsParams :: !XParams
|
||||
}
|
||||
|
||||
instance HasLogFunc DepStage where
|
||||
logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
|
||||
|
||||
instance HasProcessContext DepStage where
|
||||
processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y })
|
||||
|
||||
data XParams = XParams
|
||||
{ xpLogLevel :: LogLevel
|
||||
|
|
@ -645,27 +649,27 @@ testIODep_ :: IODependency_ -> FIO MResult_
|
|||
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
|
||||
|
||||
testIODepNoCache_ :: IODependency_ -> FIO Result_
|
||||
testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
|
||||
testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t
|
||||
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
|
||||
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
|
||||
testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
|
||||
<$> evalSometimesMsg x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | System Dependency Testing
|
||||
|
||||
testSysDependency :: SystemDependency -> IO (Maybe Msg)
|
||||
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
||||
testSysDependency :: SystemDependency -> FIO (Maybe Msg)
|
||||
testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing)
|
||||
<$> findExecutable bin
|
||||
where
|
||||
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
|
||||
e = if sys then "system" else "local"
|
||||
testSysDependency (Systemd t n) = shellTest cmd msg
|
||||
testSysDependency (Systemd t n) = shellTest "systemctl" args msg
|
||||
where
|
||||
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
||||
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
||||
testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
|
||||
args = ["--user" | t == UserUnit] ++ ["status", n]
|
||||
testSysDependency (Process n) = shellTest "pidof" [n]
|
||||
$ T.unwords ["Process", singleQuote n, "not found"]
|
||||
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
|
||||
where
|
||||
testPerm False _ _ = Nothing
|
||||
testPerm True f res = Just $ f res
|
||||
|
|
@ -679,9 +683,9 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
|||
(_, Just False) -> mkErr "file not writable"
|
||||
_ -> Nothing
|
||||
|
||||
shellTest :: T.Text -> T.Text -> IO (Maybe Msg)
|
||||
shellTest cmd msg = do
|
||||
(rc, _, _) <- readCreateProcessWithExitCode (shell $ T.unpack cmd) ""
|
||||
shellTest :: FilePath -> [T.Text] -> T.Text -> FIO (Maybe Msg)
|
||||
shellTest cmd args msg = do
|
||||
rc <- proc cmd (T.unpack <$> args) runProcess
|
||||
return $ case rc of
|
||||
ExitSuccess -> Nothing
|
||||
_ -> Just $ Msg LevelError msg
|
||||
|
|
@ -722,19 +726,19 @@ fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
|
|||
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
|
||||
|
||||
fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_
|
||||
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
|
||||
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont fam
|
||||
|
||||
fontTestName :: T.Text -> T.Text
|
||||
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
|
||||
|
||||
testFont :: T.Text -> FIO (Result FontBuilder)
|
||||
testFont = liftIO . testFont'
|
||||
-- testFont :: T.Text -> FIO (Result FontBuilder)
|
||||
-- testFont = liftIO . testFont'
|
||||
|
||||
testFont' :: T.Text -> IO (Result FontBuilder)
|
||||
testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
|
||||
testFont :: T.Text -> FIO (Result FontBuilder)
|
||||
testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
|
||||
where
|
||||
msg = T.unwords ["font family", qFam, "not found"]
|
||||
cmd = fmtCmd "fc-list" ["-q", qFam]
|
||||
args = [qFam]
|
||||
qFam = singleQuote fam
|
||||
pass = Right $ PostPass (buildFont $ Just fam) []
|
||||
|
||||
|
|
@ -781,7 +785,7 @@ readInterface n f = IORead n [] go
|
|||
|
||||
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
|
||||
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
|
||||
. socketExists'
|
||||
. io . socketExists'
|
||||
|
||||
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
||||
socketExists' getPath = do
|
||||
|
|
|
|||
Loading…
Reference in New Issue