ENH use cache (kinda) for dependency tree testing
This commit is contained in:
parent
3644efe205
commit
7cfb799698
|
|
@ -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
|
||||
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
||||
getAllCommands right = BarRegions
|
||||
{ brLeft = [ CmdSpec
|
||||
{ csAlias = "UnsafeStdinReader"
|
||||
, csRunnable = Run UnsafeStdinReader
|
||||
}
|
||||
]
|
||||
return $ BarRegions
|
||||
{ brLeft = left
|
||||
, 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue