ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use cache (kinda) for dependency tree testing

This commit is contained in:
Nathan Dwarshuis 2022-07-04 12:30:13 -04:00
parent 3644efe205
commit 7cfb799698
5 changed files with 151 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
bin/xmobar.hs
View File

@ -33,6 +33,7 @@ import System.Posix.Signals
import XMonad.Core import XMonad.Core
( cfgDir ( cfgDir
, getDirectories , getDirectories
, io
) )
import XMonad.Hooks.DynamicLog (wrap) import XMonad.Hooks.DynamicLog (wrap)
import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.Command.Power (hasBattery)
@ -55,7 +56,7 @@ import Xmobar.Plugins.Common
main :: IO () main :: IO ()
main = do main = do
db <- connectDBus db <- connectDBus
c <- evalConfig db c <- withCache $ evalConfig db
disconnectDBus db disconnectDBus db
-- this is needed to prevent waitForProcess error when forking in plugins (eg -- this is needed to prevent waitForProcess error when forking in plugins (eg
-- alsacmd) -- alsacmd)
@ -64,12 +65,12 @@ main = do
hFlush stdout hFlush stdout
xmobar c xmobar c
evalConfig :: DBusState -> IO Config evalConfig :: DBusState -> FIO Config
evalConfig db = do evalConfig db = do
cs <- getAllCommands =<< rightPlugins db cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont bf <- getTextFont
(ifs, ios) <- getIconFonts (ifs, ios) <- getIconFonts
d <- cfgDir <$> getDirectories d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d return $ config bf ifs ios cs d
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -151,21 +152,18 @@ config bf ifs ios br confDir = defaultConfig
-- some commands depend on the presence of interfaces that can only be -- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here -- determined at runtime; define these checks here
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions getAllCommands :: [Maybe CmdSpec] -> BarRegions
getAllCommands right = do getAllCommands right = BarRegions
let left = { brLeft = [ CmdSpec
[ CmdSpec
{ csAlias = "UnsafeStdinReader" { csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader , csRunnable = Run UnsafeStdinReader
} }
] ]
return $ BarRegions
{ brLeft = left
, brCenter = [] , brCenter = []
, brRight = catMaybes right , brRight = catMaybes right
} }
rightPlugins :: DBusState -> IO [Maybe CmdSpec] rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys } rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
= mapM evalFeature = mapM evalFeature
[ Left getWireless [ Left getWireless
@ -201,13 +199,13 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" root tree getBattery = iconIO_ "battery level indicator" root tree
where where
root useIcon = IORoot_ (batteryCmd useIcon) root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ sysTest "Test if battery is present" hasBattery tree = Only_ $ IOTest_ "Test if battery is present" hasBattery
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd vpnDep test getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd vpnDep test
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
@ -451,7 +449,7 @@ vpnPresent =
-- 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 :: IO String getTextFont :: FIO String
getTextFont = do getTextFont = do
fb <- evalAlways textFont fb <- evalAlways textFont
return $ fb textFontData return $ fb textFontData
@ -459,7 +457,7 @@ getTextFont = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | icon fonts -- | icon fonts
getIconFonts :: IO ([String], [Int]) getIconFonts :: FIO ([String], [Int])
getIconFonts = do getIconFonts = do
fb <- evalSometimes iconFont fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb return $ maybe ([], []) apply fb

28
bin/xmonad.hs
View File

@ -7,6 +7,7 @@
module Main (main) where module Main (main) where
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Lifted (fork)
import Control.Monad import Control.Monad
import Data.List import Data.List
@ -76,12 +77,13 @@ main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse [] = run parse [] = run
parse ["--deps"] = printDeps parse ["--deps"] = withCache printDeps
parse _ = usage parse _ = usage
run :: IO () run :: IO ()
run = do run = do
conf <- evalConf =<< connectDBusX db <- connectDBusX
conf <- withCache $ evalConf db
ds <- getDirectories ds <- getDirectories
-- IDK why this is necessary; nothing prior to this will print if missing -- IDK why this is necessary; nothing prior to this will print if missing
hFlush stdout hFlush stdout
@ -157,29 +159,29 @@ evalConf db = do
startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters features $ fsDBusExporters features
startChildDaemons = do startChildDaemons = do
(h, p) <- spawnPipe "xmobar" (h, p) <- io $ spawnPipe "xmobar"
ps <- catMaybes <$> mapM executeSometimes (fsDaemons features) ps <- catMaybes <$> mapM executeSometimes (fsDaemons features)
return (h, ThreadState (p:ps) [h]) return (h, ThreadState (p:ps) [h])
startRemovableMon = void $ executeSometimes $ fsRemovableMon features startRemovableMon = void $ executeSometimes $ fsRemovableMon features
$ dbSysClient db $ dbSysClient db
startPowerMon = forkIO_ $ void $ executeSometimes $ fsPowerMon features startPowerMon = void $ fork $ void $ executeSometimes $ fsPowerMon features
startDynWorkspaces = do startDynWorkspaces = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features) dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features)
forkIO_ $ runWorkspaceMon dws io $ forkIO_ $ runWorkspaceMon dws
return dws return dws
printDeps :: IO () printDeps :: FIO ()
printDeps = do printDeps = do
db <- connectDBus db <- io connectDBus
(i, f, d) <- allFeatures db (i, f, d) <- allFeatures db
is <- mapM dumpSometimes i is <- mapM dumpSometimes i
fs <- mapM dumpFeature f fs <- mapM dumpFeature f
ds <- mapM dumpSometimes d ds <- mapM dumpSometimes d
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds
putStrLn u io $ putStrLn u
disconnectDBus db io $ disconnectDBus db
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = do allFeatures db = do
let bfs = concatMap (fmap kbMaybeAction . kgBindings) let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db $ externalBindings ts db
@ -260,7 +262,7 @@ vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root
where where
root = IORoot_ dw $ And_ (Only_ $ sysExe "VBoxManage") root = IORoot_ dw $ And_ (Only_ $ sysExe "VBoxManage")
$ Only_ $ sysTest name $ vmExists vm $ Only_ $ IOTest_ name $ vmExists vm
name = unwords ["test if", vm, "exists"] name = unwords ["test if", vm, "exists"]
c = "VirtualBoxVM" c = "VirtualBoxVM"
vm = "win8raw" vm = "win8raw"
@ -595,13 +597,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a] , kgBindings :: [KeyBinding a]
} }
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX] evalExternal :: [KeyGroup FeatureX] -> FIO [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 -> IO (KeyBinding MaybeX) evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbMaybeAction = a } = evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a (\f -> k { kbMaybeAction = f }) <$> evalFeature a

165
lib/XMonad/Internal/Dependency.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -51,6 +52,8 @@ module XMonad.Internal.Dependency
, JSONMixed(..) , JSONMixed(..)
-- testing -- testing
, FIO
, withCache
, evalFeature , evalFeature
, executeSometimes , executeSometimes
, executeAlways , executeAlways
@ -81,7 +84,7 @@ module XMonad.Internal.Dependency
, pathR , pathR
, pathRW , pathRW
, pathW , pathW
, sysTest -- , sysTest
, voidResult , voidResult
, voidRead , voidRead
@ -91,11 +94,16 @@ module XMonad.Internal.Dependency
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.State
import Data.Bifunctor import Data.Bifunctor
import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import GHC.Generics (Generic)
import DBus import DBus
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
@ -116,29 +124,34 @@ import XMonad.Internal.Shell
-- Here we attempt to build and return the monadic actions encoded by each -- Here we attempt to build and return the monadic actions encoded by each
-- feature. -- feature.
-- | 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 = evalStateT x emptyCache
-- | Execute an Always immediately -- | Execute an Always immediately
executeAlways :: MonadIO m => Always (m a) -> m a executeAlways :: Always (IO a) -> FIO a
executeAlways = join . evalAlways executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure) -- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a) executeSometimes :: Sometimes (IO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes -- | Possibly return the action of an Always/Sometimes
evalFeature :: MonadIO m => Feature a -> m (Maybe a) evalFeature :: Feature a -> FIO (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 :: MonadIO m => Sometimes a -> m (Maybe a) evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = io $ either goFail goPass =<< evalSometimesMsg x evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where where
goPass (PostPass a ws) = putErrors ws >> return (Just a) goPass (PostPass a ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing goFail es = putErrors es >> return Nothing
putErrors = mapM_ putStrLn putErrors = io . mapM_ putStrLn
-- | Return the action of an Always -- | Return the action of an Always
evalAlways :: MonadIO m => Always a -> m a evalAlways :: Always a -> FIO a
evalAlways a = do evalAlways a = do
(PostPass x ws) <- evalAlwaysMsg a (PostPass x ws) <- evalAlwaysMsg a
io $ mapM_ putStrLn ws io $ mapM_ putStrLn ws
@ -148,11 +161,11 @@ evalAlways a = do
-- | Feature status -- | Feature status
-- | Dump the status of a Feature -- | Dump the status of a Feature
dumpFeature :: Feature a -> IO JSONUnquotable dumpFeature :: Feature a -> FIO JSONUnquotable
dumpFeature = either dumpSometimes dumpAlways dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout -- | Dump the status of an Always to stdout
dumpAlways :: Always a -> IO JSONUnquotable dumpAlways :: Always a -> FIO JSONUnquotable
dumpAlways (Always n x) = go [] x dumpAlways (Always n x) = go [] x
where where
go failed (Option o os) = do go failed (Option o os) = do
@ -165,7 +178,7 @@ dumpAlways (Always n x) = go [] x
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
-- | Dump the status of a Sometimes to stdout -- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> IO JSONUnquotable dumpSometimes :: Sometimes a -> FIO JSONUnquotable
dumpSometimes (Sometimes n a) = go [] a dumpSometimes (Sometimes n a) = go [] a
where where
go failed [] = return $ jsonSometimes (Q n) Nothing failed [] go failed [] = return $ jsonSometimes (Q n) Nothing failed []
@ -277,18 +290,29 @@ data DBusDependency_ = Bus BusName
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ SystemDependency data IODependency_ = IOSystem_ SystemDependency
| IOTest_ String (IO (Maybe String))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
-- instance Eq IODependency_ where
-- (==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1
-- (==) (IOTest_ _ _) (IOTest_ _ _) = False
-- (==) (IOSometimes_ _) (IOSometimes_ _) = False
-- (==) _ _ = False
-- | A system component to an IODependency -- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious -- This name is dumb, but most constructors should be obvious
data SystemDependency = data SystemDependency =
Executable Bool FilePath Executable Bool FilePath
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String))
| Systemd UnitType String | Systemd UnitType String
deriving (Eq, Show, Generic)
instance Hashable SystemDependency
-- | The type of a systemd service -- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
instance Hashable UnitType
-- | Wrapper type to describe and endpoint -- | Wrapper type to describe and endpoint
data DBusMember = Method_ MemberName data DBusMember = Method_ MemberName
@ -327,24 +351,52 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed -- | An action that failed
data PostFail = PostFail [String] | PostMissing String data PostFail = PostFail [String] | PostMissing String
--------------------------------------------------------------------------------
-- | Evaluation cache
--
-- Setting up trees like this usually entails having some repeated dependencies.
-- Testing the same dependency multiple times is stupid, so cache the results.
-- Note this is basically memorization, except that the results are IO-dependent
-- and this may technically change with each invocation. The assumption here is
-- that each repeated test without caching would be run in such close succession
-- that the results will always be the same.
type FIO a = StateT Cache IO a
newtype Cache = Cache
{ cSys :: H.HashMap SystemDependency Result_
-- , cIO :: forall p. H.HashMap (IODependency p) (Result p)
-- , cIO_ :: H.HashMap IODependency_ Result_
-- , cDBus :: H.HashMap DBusDependency_ Result_
}
emptyCache :: Cache
emptyCache = Cache H.empty
memoizeSys :: (SystemDependency -> IO Result_) -> SystemDependency -> FIO Result_
memoizeSys f d = do
m <- gets cSys
let r = H.lookup d m
maybe (io $ f d) return r
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Testing pipeline -- | Testing pipeline
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a) evalSometimesMsg :: Sometimes a -> FIO (Result a)
evalSometimesMsg (Sometimes n xs) = io $ do evalSometimesMsg (Sometimes n xs) = do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of case s of
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs (Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgsIO False n fs
_ -> Left <$> failedMsgs True n fs _ -> Left <$> failedMsgsIO True n fs
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a) evalAlwaysMsg :: Always a -> FIO (PostPass a)
evalAlwaysMsg (Always n x) = io $ do evalAlwaysMsg (Always n x) = do
r <- testAlways x r <- testAlways x
case r of case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs (Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgsIO False n fs
(Fallback act fs) -> PostPass act <$> failedMsgs False n fs (Fallback act fs) -> PostPass act <$> failedMsgsIO False n fs
testAlways :: Always_ a -> IO (PostAlways a) testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go [] testAlways = go []
where where
go failed (Option fd next) = do go failed (Option fd next) = do
@ -354,18 +406,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 -> IO a evalFallbackRoot :: FallbackRoot a -> FIO 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 -> IO p evalFallbackStack :: FallbackStack p -> FIO 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 -> IO (PostSometimes a) testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing []) testSometimes = go (PostSometimes Nothing [])
where where
go ts [] = return ts go ts [] = return ts
@ -375,13 +427,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 -> IO (Either SubfeatureFail (SubfeaturePass a)) testSubfeature :: SubfeatureRoot a -> FIO (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 -> IO (Either PostFail (PostPass a)) testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do testRoot r = do
case r of case r of
(IORoot a t) -> go a testIODependency_ testIODependency t (IORoot a t) -> go a testIODependency_ testIODependency t
@ -391,7 +443,7 @@ testRoot r = do
_ -> return $ Left $ PostMissing "client not available" _ -> return $ Left $ PostMissing "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 -> IO (Result q)) t = go a f_ (f :: forall q. d q -> FIO (Result 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
@ -400,11 +452,11 @@ testRoot r = do
type Result p = Either [String] (PostPass p) type Result p = Either [String] (PostPass p)
testTree :: forall d d_ p. (d_ -> IO Result_) -> (forall q. d q -> IO (Result q)) testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q))
-> Tree d d_ p -> IO (Either [String] (PostPass p)) -> Tree d d_ p -> FIO (Either [String] (PostPass p))
testTree test_ test = go testTree test_ test = go
where where
go :: forall q. Tree d d_ q -> IO (Either [String] (PostPass q)) go :: forall q. Tree d d_ q -> FIO (Either [String] (PostPass 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
@ -421,8 +473,8 @@ 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)
testIODependency :: IODependency p -> IO (Result p) testIODependency :: IODependency p -> FIO (Result p)
testIODependency (IORead _ t) = t testIODependency (IORead _ t) = io t
testIODependency (IOConst c) = return $ Right $ PostPass c [] testIODependency (IOConst c) = return $ Right $ PostPass c []
-- TODO this is a bit odd because this is a dependency that will always -- TODO this is a bit odd because this is a dependency that will always
-- succeed, which kinda makes this pointless. The only reason I would want this -- succeed, which kinda makes this pointless. The only reason I would want this
@ -436,7 +488,7 @@ testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
type Result_ = Either [String] [String] type Result_ = Either [String] [String]
testTree_ :: (d -> IO Result_) -> Tree_ d -> IO (Either [String] [String]) testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO (Either [String] [String])
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
@ -444,15 +496,15 @@ testTree_ test = go
go (Only_ a) = test a go (Only_ a) = test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> IO Result_ testIODependency_ :: IODependency_ -> FIO Result_
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s testIODependency_ (IOSystem_ s) = memoizeSys (fmap readResult_ . testSysDependency) s
testIODependency_ (IOTest_ _ t) = io $ readResult_ <$> t
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System Dependency Testing -- | System Dependency Testing
testSysDependency :: SystemDependency -> IO (Maybe String) testSysDependency :: SystemDependency -> IO (Maybe String)
testSysDependency (IOTest _ t) = t
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
<$> findExecutable bin <$> findExecutable bin
where where
@ -496,8 +548,8 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_ testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency_ client (Bus bus) = do testDBusDependency_ client (Bus bus) = io $ do
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [e]
@ -513,7 +565,7 @@ testDBusDependency_ client (Bus bus) = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] bodyGetNames _ = []
testDBusDependency_ client (Endpoint busname objpath iface mem) = do testDBusDependency_ client (Endpoint busname objpath iface mem) = io $ do
ret <- callMethod client busname objpath introspectInterface introspectMethod ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [e]
@ -632,6 +684,10 @@ voidRead (Left []) = Just "unspecified error"
voidRead (Left (e:_)) = Just e voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing voidRead (Right _) = Nothing
readResult_ :: Maybe String -> Result_
readResult_ (Just w) = Left [w]
readResult_ _ = Right []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Dependency Constructors -- | IO Dependency Constructors
@ -662,17 +718,17 @@ sysdUser = sysd UserUnit
sysdSystem :: String -> IODependency_ sysdSystem :: String -> IODependency_
sysdSystem = sysd SystemUnit sysdSystem = sysd SystemUnit
sysTest :: String -> IO (Maybe String) -> IODependency_ -- sysTest :: String -> IO (Maybe String) -> IODependency_
sysTest n = IOSystem_ . IOTest n -- sysTest n = IOSystem_ . IOTest n
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing -- | Printing
dumpSubfeatureRoot :: SubfeatureRoot a -> IO (JSONUnquotable, Bool) dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (JSONUnquotable, Bool)
dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } = dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } =
first (jsonSubfeature $ Q n) <$> dumpRoot r first (jsonSubfeature $ Q n) <$> dumpRoot r
dumpRoot :: Root a -> IO (JSONUnquotable, Bool) dumpRoot :: Root a -> FIO (JSONUnquotable, Bool)
dumpRoot (IORoot _ t) = first jsonIORoot <$> dumpRoot (IORoot _ t) = first jsonIORoot <$>
dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t
dumpRoot (IORoot_ _ t) = first jsonIORoot <$> dumpRoot (IORoot_ _ t) = first jsonIORoot <$>
@ -687,12 +743,12 @@ dumpRoot (DBusRoot _ t Nothing) =
dumpRoot (DBusRoot_ _ t Nothing) = dumpRoot (DBusRoot_ _ t Nothing) =
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False) return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
dumpTree :: forall d d_ p. (forall q. d q -> IO (Result q)) dumpTree :: forall d d_ p. (forall q. d q -> FIO (Result q))
-> (d_ -> IO Result_) -> (forall q. d q -> DependencyData) -> (d_ -> FIO Result_) -> (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> IO (JSONUnquotable, Bool) -> (d_ -> DependencyData) -> Tree d d_ p -> FIO (JSONUnquotable, Bool)
dumpTree test test_ dd dd_ = go dumpTree test test_ dd dd_ = go
where where
go :: forall q. Tree d d_ q -> IO (JSONUnquotable, Bool) go :: forall q. Tree d d_ q -> FIO (JSONUnquotable, Bool)
go (And12 _ a b) = doAnd go go data' a b go (And12 _ a b) = doAnd go go data' a b
go (And1 a b) = doAnd go dump_' (dataTree_ dd_) a b go (And1 a b) = doAnd go dump_' (dataTree_ dd_) a b
go (And2 a b) = doAnd dump_' go data' a b go (And2 a b) = doAnd dump_' go data' a b
@ -712,8 +768,8 @@ dumpTree test test_ dd dd_ = go
let j = jsonAnd sa let j = jsonAnd sa
if ra then first j <$> fb b else return (j $ fb_ b, ra) if ra then first j <$> fb b else return (j $ fb_ b, ra)
dumpTree_ :: (d_ -> IO Result_) -> (d_ -> DependencyData) -> Tree_ d_ dumpTree_ :: (d_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_
-> IO (JSONUnquotable, Bool) -> FIO (JSONUnquotable, Bool)
dumpTree_ test_ dd_ = go dumpTree_ test_ dd_ = go
where where
go (And_ a b) = do go (And_ a b) = do
@ -773,6 +829,7 @@ dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of dataIODependency_ d = case d of
(IOSystem_ s) -> dataSysDependency s (IOSystem_ s) -> dataSysDependency s
(IOSometimes_ _) -> (Q "sometimes", []) (IOSometimes_ _) -> (Q "sometimes", [])
(IOTest_ desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
dataSysDependency :: SystemDependency -> DependencyData dataSysDependency :: SystemDependency -> DependencyData
dataSysDependency d = first Q $ dataSysDependency d = first Q $
@ -780,7 +837,6 @@ dataSysDependency d = first Q $
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys) (Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
, ("path", JSON_Q $ Q path) , ("path", JSON_Q $ Q path)
]) ])
(IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p) (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r) , ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w) , ("writable", JSON_UQ $ jsonBool w)
@ -915,6 +971,9 @@ curly s = "{" ++ s ++ "}"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other random formatting -- | Other random formatting
failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [String]
failedMsgsIO err fn = io . failedMsgs err fn
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String] failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
failedMsgs err fn = fmap concat . mapM (failedMsg err fn) failedMsgs err fn = fmap concat . mapM (failedMsg err fn)

2
lib/XMonad/Internal/Theme.hs
View File

@ -158,7 +158,7 @@ fontDependency fam =
IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam
fontDependency_ :: String -> IODependency_ fontDependency_ :: String -> IODependency_
fontDependency_ fam = sysTest n $ voidRead <$> testFont fam fontDependency_ fam = IOTest_ n $ voidRead <$> testFont fam
where where
n = unwords ["test if font", singleQuote fam, "exists"] n = unwords ["test if font", singleQuote fam, "exists"]

3
my-xmonad.cabal
View File

@ -54,6 +54,8 @@ library
, xmonad >= 0.13 , xmonad >= 0.13
, xmonad-contrib >= 0.13 , xmonad-contrib >= 0.13
, aeson >= 2.0.3.0 , aeson >= 2.0.3.0
, unordered-containers >= 0.2.16.0
, hashable >= 1.3.5.0
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010
@ -65,6 +67,7 @@ executable xmonad
, my-xmonad , my-xmonad
, xmonad >= 0.13 , xmonad >= 0.13
, xmonad-contrib >= 0.13 , xmonad-contrib >= 0.13
, lifted-base >= 0.2.3.12
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded