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

42
bin/xmobar.hs
View File

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

28
bin/xmonad.hs
View File

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

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

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -51,6 +52,8 @@ module XMonad.Internal.Dependency
, JSONMixed(..)
-- testing
, FIO
, withCache
, evalFeature
, executeSometimes
, executeAlways
@ -81,7 +84,7 @@ module XMonad.Internal.Dependency
, pathR
, pathRW
, pathW
, sysTest
-- , sysTest
, voidResult
, voidRead
@ -91,11 +94,16 @@ module XMonad.Internal.Dependency
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.State
import Data.Bifunctor
import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.List
import Data.Maybe
import GHC.Generics (Generic)
import DBus
import DBus.Client
import DBus.Internal
@ -116,29 +124,34 @@ import XMonad.Internal.Shell
-- Here we attempt to build and return the monadic actions encoded by each
-- 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
executeAlways :: MonadIO m => Always (m a) -> m a
executeAlways = join . evalAlways
executeAlways :: Always (IO a) -> FIO a
executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
executeSometimes :: Sometimes (IO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes a
-- | 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 (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
evalSometimes x = io $ either goFail goPass =<< evalSometimesMsg x
evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
goPass (PostPass a ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing
putErrors = mapM_ putStrLn
putErrors = io . mapM_ putStrLn
-- | Return the action of an Always
evalAlways :: MonadIO m => Always a -> m a
evalAlways :: Always a -> FIO a
evalAlways a = do
(PostPass x ws) <- evalAlwaysMsg a
io $ mapM_ putStrLn ws
@ -148,11 +161,11 @@ evalAlways a = do
-- | Feature status
-- | Dump the status of a Feature
dumpFeature :: Feature a -> IO JSONUnquotable
dumpFeature :: Feature a -> FIO JSONUnquotable
dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout
dumpAlways :: Always a -> IO JSONUnquotable
dumpAlways :: Always a -> FIO JSONUnquotable
dumpAlways (Always n x) = go [] x
where
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
-- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> IO JSONUnquotable
dumpSometimes :: Sometimes a -> FIO JSONUnquotable
dumpSometimes (Sometimes n a) = go [] a
where
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)
data IODependency_ = IOSystem_ SystemDependency
| IOTest_ String (IO (Maybe String))
| 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
-- This name is dumb, but most constructors should be obvious
data SystemDependency =
Executable Bool FilePath
| AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String))
| Systemd UnitType String
deriving (Eq, Show, Generic)
instance Hashable SystemDependency
-- | 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
data DBusMember = Method_ MemberName
@ -327,24 +351,52 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed
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
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
evalSometimesMsg (Sometimes n xs) = io $ do
evalSometimesMsg :: Sometimes a -> FIO (Result a)
evalSometimesMsg (Sometimes n xs) = do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs
_ -> Left <$> failedMsgs True n fs
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgsIO False n fs
_ -> Left <$> failedMsgsIO True n fs
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
evalAlwaysMsg (Always n x) = io $ do
evalAlwaysMsg :: Always a -> FIO (PostPass a)
evalAlwaysMsg (Always n x) = do
r <- testAlways x
case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs
(Fallback act fs) -> PostPass act <$> failedMsgs False n fs
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgsIO 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 []
where
go failed (Option fd next) = do
@ -354,18 +406,18 @@ testAlways = go []
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> IO a
evalFallbackRoot :: FallbackRoot a -> FIO a
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> IO p
evalFallbackStack :: FallbackStack p -> FIO 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 -> IO (PostSometimes a)
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
@ -375,13 +427,13 @@ testSometimes = go (PostSometimes Nothing [])
(Left l) -> go (ts { psFailed = l:psFailed ts }) xs
(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
t' <- testRoot t
-- monomorphism restriction :(
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
case r of
(IORoot a t) -> go a testIODependency_ testIODependency t
@ -391,7 +443,7 @@ testRoot r = do
_ -> return $ Left $ PostMissing "client not available"
where
-- 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
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)
testTree :: forall d d_ p. (d_ -> IO Result_) -> (forall q. d q -> IO (Result q))
-> Tree d d_ p -> IO (Either [String] (PostPass p))
testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q))
-> Tree d d_ p -> FIO (Either [String] (PostPass p))
testTree test_ test = go
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
ra <- go a
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
liftRight = either (return . Left)
testIODependency :: IODependency p -> IO (Result p)
testIODependency (IORead _ t) = t
testIODependency :: IODependency p -> FIO (Result p)
testIODependency (IORead _ t) = io t
testIODependency (IOConst c) = return $ Right $ PostPass c []
-- 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
@ -436,7 +488,7 @@ testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
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
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -444,15 +496,15 @@ testTree_ test = go
go (Only_ a) = test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> IO Result_
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
testIODependency_ :: IODependency_ -> FIO Result_
testIODependency_ (IOSystem_ s) = memoizeSys (fmap readResult_ . testSysDependency) s
testIODependency_ (IOTest_ _ t) = io $ readResult_ <$> t
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
--------------------------------------------------------------------------------
-- | System Dependency Testing
testSysDependency :: SystemDependency -> IO (Maybe String)
testSysDependency (IOTest _ t) = t
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
<$> findExecutable bin
where
@ -496,8 +548,8 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
testDBusDependency_ client (Bus bus) = do
testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
testDBusDependency_ client (Bus bus) = io $ do
ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of
Left e -> Left [e]
@ -513,7 +565,7 @@ testDBusDependency_ client (Bus bus) = do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
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
return $ case ret of
Left e -> Left [e]
@ -632,6 +684,10 @@ voidRead (Left []) = Just "unspecified error"
voidRead (Left (e:_)) = Just e
voidRead (Right _) = Nothing
readResult_ :: Maybe String -> Result_
readResult_ (Just w) = Left [w]
readResult_ _ = Right []
--------------------------------------------------------------------------------
-- | IO Dependency Constructors
@ -662,17 +718,17 @@ sysdUser = sysd UserUnit
sysdSystem :: String -> IODependency_
sysdSystem = sysd SystemUnit
sysTest :: String -> IO (Maybe String) -> IODependency_
sysTest n = IOSystem_ . IOTest n
-- sysTest :: String -> IO (Maybe String) -> IODependency_
-- sysTest n = IOSystem_ . IOTest n
--------------------------------------------------------------------------------
-- | Printing
dumpSubfeatureRoot :: SubfeatureRoot a -> IO (JSONUnquotable, Bool)
dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (JSONUnquotable, Bool)
dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } =
first (jsonSubfeature $ Q n) <$> dumpRoot r
dumpRoot :: Root a -> IO (JSONUnquotable, Bool)
dumpRoot :: Root a -> FIO (JSONUnquotable, Bool)
dumpRoot (IORoot _ t) = first jsonIORoot <$>
dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t
dumpRoot (IORoot_ _ t) = first jsonIORoot <$>
@ -687,12 +743,12 @@ dumpRoot (DBusRoot _ t Nothing) =
dumpRoot (DBusRoot_ _ t Nothing) =
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
dumpTree :: forall d d_ p. (forall q. d q -> IO (Result q))
-> (d_ -> IO Result_) -> (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> IO (JSONUnquotable, Bool)
dumpTree :: forall d d_ p. (forall q. d q -> FIO (Result q))
-> (d_ -> FIO Result_) -> (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> FIO (JSONUnquotable, Bool)
dumpTree test test_ dd dd_ = go
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 (And1 a b) = doAnd go dump_' (dataTree_ dd_) 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
if ra then first j <$> fb b else return (j $ fb_ b, ra)
dumpTree_ :: (d_ -> IO Result_) -> (d_ -> DependencyData) -> Tree_ d_
-> IO (JSONUnquotable, Bool)
dumpTree_ :: (d_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_
-> FIO (JSONUnquotable, Bool)
dumpTree_ test_ dd_ = go
where
go (And_ a b) = do
@ -773,6 +829,7 @@ dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of
(IOSystem_ s) -> dataSysDependency s
(IOSometimes_ _) -> (Q "sometimes", [])
(IOTest_ desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
dataSysDependency :: SystemDependency -> DependencyData
dataSysDependency d = first Q $
@ -780,7 +837,6 @@ dataSysDependency d = first Q $
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
, ("path", JSON_Q $ Q path)
])
(IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w)
@ -915,6 +971,9 @@ curly s = "{" ++ s ++ "}"
--------------------------------------------------------------------------------
-- | Other random formatting
failedMsgsIO :: Bool -> String -> [SubfeatureFail] -> FIO [String]
failedMsgsIO err fn = io . failedMsgs err fn
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
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
fontDependency_ :: String -> IODependency_
fontDependency_ fam = sysTest n $ voidRead <$> testFont fam
fontDependency_ fam = IOTest_ n $ voidRead <$> testFont fam
where
n = unwords ["test if font", singleQuote fam, "exists"]

3
my-xmonad.cabal
View File

@ -54,6 +54,8 @@ library
, xmonad >= 0.13
, xmonad-contrib >= 0.13
, 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
default-language: Haskell2010
@ -65,6 +67,7 @@ executable xmonad
, my-xmonad
, xmonad >= 0.13
, xmonad-contrib >= 0.13
, lifted-base >= 0.2.3.12
default-language: Haskell2010
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded