ENH dump feature configuration
This commit is contained in:
parent
caefbfc78a
commit
98a8da5168
|
|
@ -119,32 +119,27 @@ run = do
|
|||
forkIO_ = void . forkIO
|
||||
|
||||
printDeps :: IO ()
|
||||
printDeps = skip
|
||||
-- (i, x) <- allFeatures
|
||||
-- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
|
||||
-- where
|
||||
-- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
|
||||
-- extractFeatures (Always _) = []
|
||||
-- dtDeps (GenTree _ ds) = ds
|
||||
-- dtDeps (DBusTree _ _ ds) = ds
|
||||
-- printDep (FullDep d) = putStrLn . depName d
|
||||
printDeps = do
|
||||
ses <- getDBusClient False
|
||||
sys <- getDBusClient True
|
||||
let db = DBusState ses sys
|
||||
(i, f) <- allFeatures db
|
||||
is <- mapM dumpSometimes i
|
||||
fs <- mapM dumpFeature f
|
||||
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs
|
||||
putStrLn u
|
||||
forM_ ses disconnect
|
||||
forM_ sys disconnect
|
||||
|
||||
-- allFeatures :: IO ([FeatureIO], [FeatureX])
|
||||
-- allFeatures = do
|
||||
-- ses <- getDBusClient False
|
||||
-- sys <- getDBusClient True
|
||||
-- let db = DBusState ses sys
|
||||
-- lockRes <- evalFeature runScreenLock
|
||||
-- let lock = whenSatisfied lockRes
|
||||
-- let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||
-- $ externalBindings ts db lock
|
||||
-- let dbus = fmap (\f -> f ses) dbusExporters
|
||||
-- let others = [runRemovableMon sys, runPowermon]
|
||||
-- forM_ ses disconnect
|
||||
-- forM_ sys disconnect
|
||||
-- return (dbus ++ others, bfs)
|
||||
-- where
|
||||
-- ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX])
|
||||
allFeatures db = do
|
||||
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||
$ externalBindings ts db
|
||||
let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters
|
||||
let others = [runRemovableMon $ dbSystemClient db, runPowermon]
|
||||
return (dbus ++ others, Left runScreenLock:bfs)
|
||||
where
|
||||
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||
|
||||
usage :: IO ()
|
||||
usage = putStrLn $ intercalate "\n"
|
||||
|
|
@ -538,13 +533,13 @@ data KeyGroup a = KeyGroup
|
|||
, kgBindings :: [KeyBinding a]
|
||||
}
|
||||
|
||||
evalExternal :: [KeyGroup (FeatureX)] -> IO [KeyGroup MaybeX]
|
||||
evalExternal :: [KeyGroup FeatureX] -> IO [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 -> IO (KeyBinding MaybeX)
|
||||
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
|
||||
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Functions for handling dependencies
|
||||
|
|
@ -30,6 +31,15 @@ module XMonad.Internal.Dependency
|
|||
, UnitType(..)
|
||||
, Result
|
||||
|
||||
-- dumping
|
||||
, dumpFeature
|
||||
, dumpAlways
|
||||
, dumpSometimes
|
||||
, jsonArray
|
||||
, JSONQuotable(..)
|
||||
, JSONUnquotable(..)
|
||||
, JSONMixed(..)
|
||||
|
||||
-- testing
|
||||
, evalFeature
|
||||
, executeSometimes
|
||||
|
|
@ -66,11 +76,9 @@ module XMonad.Internal.Dependency
|
|||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Identity
|
||||
|
||||
-- import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.List (find)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
-- import qualified Data.Text as T
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
|
@ -123,13 +131,33 @@ evalAlways a = do
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Feature status
|
||||
|
||||
-- | Dump the status of a Feature
|
||||
dumpFeature :: Feature a -> IO JSONUnquotable
|
||||
dumpFeature = either dumpSometimes dumpAlways
|
||||
|
||||
-- | Dump the status of an Always to stdout
|
||||
-- dumpAlways :: MonadIO m => Always a -> m ()
|
||||
-- dumpAlways = undefined
|
||||
dumpAlways :: Always a -> IO JSONUnquotable
|
||||
dumpAlways = go []
|
||||
where
|
||||
go failed (Option o os) = do
|
||||
(s, r) <- dumpSubfeatureRoot o
|
||||
if r
|
||||
then return $ jsonAlways (Just s) failed $ untested [] os
|
||||
else go (s:failed) os
|
||||
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed []
|
||||
untested acc (Always _) = acc
|
||||
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
|
||||
|
||||
-- | Dump the status of a Sometimes to stdout
|
||||
-- dumpSometimes :: MonadIO m => Sometimes a -> m ()
|
||||
-- dumpSometimes = undefined
|
||||
dumpSometimes :: Sometimes a -> IO JSONUnquotable
|
||||
dumpSometimes = go []
|
||||
where
|
||||
go failed [] = return $ jsonSometimes Nothing failed []
|
||||
go failed (x:xs) = do
|
||||
(s, r) <- dumpSubfeatureRoot x
|
||||
if r
|
||||
then return $ jsonSometimes (Just s) failed $ fmap dataSubfeatureRoot xs
|
||||
else go (s:failed) xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Wrapper types
|
||||
|
|
@ -201,12 +229,6 @@ data IODependency p = IORead String (IO (Result p))
|
|||
| forall a. IOAlways (Always a) (a -> p)
|
||||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||
|
||||
-- | A dependency pertaining to the DBus
|
||||
-- data DBusDependency p =
|
||||
-- -- Bus BusName
|
||||
-- -- | Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||
-- DBusIO (IODependency p)
|
||||
|
||||
-- | A dependency pertaining to the DBus
|
||||
data DBusDependency_ = Bus BusName
|
||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||
|
|
@ -343,6 +365,10 @@ testTree test_ test = go
|
|||
|
||||
testIODependency :: IODependency p -> IO (Result p)
|
||||
testIODependency (IORead _ t) = t
|
||||
-- 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
|
||||
-- is if I want to have a built-in logic to "choose" a payload to use in
|
||||
-- building a higher-level feature
|
||||
testIODependency (IOAlways a f) = Right . fmap f <$> evalAlwaysMsg a
|
||||
testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
|
||||
|
||||
|
|
@ -363,12 +389,15 @@ testIODependency_ :: IODependency_ -> IO Result_
|
|||
testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
|
||||
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
|
||||
msg = unwords [e, "executable", quote bin, "not found"]
|
||||
msg = unwords [e, "executable", singleQuote bin, "not found"]
|
||||
e = if sys then "system" else "local"
|
||||
testSysDependency (Systemd t n) = do
|
||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||
|
|
@ -377,8 +406,6 @@ testSysDependency (Systemd t n) = do
|
|||
_ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
|
||||
where
|
||||
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
||||
unitType SystemUnit = "system"
|
||||
unitType UserUnit = "user"
|
||||
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||
where
|
||||
testPerm False _ _ = Nothing
|
||||
|
|
@ -392,14 +419,28 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
|||
(_, Just False) -> Just "file not writable"
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
unitType :: UnitType -> String
|
||||
unitType SystemUnit = "system"
|
||||
unitType UserUnit = "user"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus Dependency Testing
|
||||
|
||||
introspectInterface :: InterfaceName
|
||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||
|
||||
introspectMethod :: MemberName
|
||||
introspectMethod = memberName_ "Introspect"
|
||||
|
||||
testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
|
||||
testDBusDependency_ client (Bus bus) = do
|
||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||
return $ case ret of
|
||||
Left e -> smryFail e
|
||||
Left e -> Left [e]
|
||||
Right b -> let ns = bodyGetNames b in
|
||||
if bus' `elem` ns then Right []
|
||||
else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
|
||||
else Left [unwords ["name", singleQuote bus', "not found on dbus"]]
|
||||
where
|
||||
bus' = formatBusName bus
|
||||
queryBus = busName_ "org.freedesktop.DBus"
|
||||
|
|
@ -412,14 +453,14 @@ testDBusDependency_ client (Bus bus) = do
|
|||
testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
||||
ret <- callMethod client busname objpath introspectInterface introspectMethod
|
||||
return $ case ret of
|
||||
Left e -> smryFail e
|
||||
Left e -> Left [e]
|
||||
Right body -> procBody body
|
||||
where
|
||||
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
|
||||
=<< listToMaybe body in
|
||||
case res of
|
||||
Just True -> Right []
|
||||
_ -> smryFail $ fmtMsg' mem
|
||||
_ -> Left [fmtMsg' mem]
|
||||
findMem = fmap (matchMem mem)
|
||||
. find (\i -> I.interfaceName i == iface)
|
||||
. I.objectInterfaces
|
||||
|
|
@ -442,7 +483,26 @@ testDBusDependency_ client (Endpoint busname objpath iface mem) = do
|
|||
testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Constructor functions
|
||||
-- | IO Lifting functions
|
||||
|
||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||
ioSometimes = fmap ioSubfeature
|
||||
|
||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||
ioAlways (Always x) = Always $ io x
|
||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||
|
||||
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||
|
||||
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||
ioRoot (IORoot a t) = IORoot (io . a) t
|
||||
ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||
ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Feature constructors
|
||||
|
||||
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
||||
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||
|
|
@ -460,33 +520,27 @@ always1 = always1_ Error
|
|||
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
||||
|
||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
||||
|
||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs n sys path args =
|
||||
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||
|
||||
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
||||
-> (Client -> a) -> Sometimes a
|
||||
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
||||
|
||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||
sometimesEndpoint name busname path iface mem client =
|
||||
sometimesDBus client name deps cmd
|
||||
where
|
||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||
cmd c = io $ void $ callMethod c busname path iface mem
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | IO Lifting functions
|
||||
|
||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||
ioSometimes = fmap ioSubfeature
|
||||
|
||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||
ioAlways (Always x) = Always $ io x
|
||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||
|
||||
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||
|
||||
-- data Msg = Msg LogLevel String String
|
||||
|
||||
ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||
ioRoot (IORoot a t) = IORoot (io . a) t
|
||||
ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||
ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||
|
||||
-- --------------------------------------------------------------------------------
|
||||
-- | Dependency Tree
|
||||
-- | Dependency Tree Constructors
|
||||
|
||||
listToAnds :: d -> [d] -> Tree_ d
|
||||
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
||||
|
|
@ -494,18 +548,8 @@ listToAnds i = foldr (And_ . Only_) (Only_ i)
|
|||
toAnd :: d -> d -> Tree_ d
|
||||
toAnd a b = And_ (Only_ a) (Only_ b)
|
||||
|
||||
smryFail :: String -> Either [String] a
|
||||
smryFail msg = Left [msg]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | IO Dependency
|
||||
|
||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
||||
|
||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
||||
sometimesExeArgs n sys path args =
|
||||
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||
-- | IO Dependency Constructors
|
||||
|
||||
exe :: Bool -> String -> IODependency_
|
||||
exe b = IOSystem_ . Executable b
|
||||
|
|
@ -537,50 +581,250 @@ sysdSystem = sysd SystemUnit
|
|||
sysTest :: String -> IO (Maybe String) -> IODependency_
|
||||
sysTest n = IOSystem_ . IOTest n
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus Dependency Result
|
||||
|
||||
introspectInterface :: InterfaceName
|
||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||
|
||||
introspectMethod :: MemberName
|
||||
introspectMethod = memberName_ "Introspect"
|
||||
|
||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||
sometimesEndpoint name busname path iface mem client =
|
||||
sometimesDBus client name deps cmd
|
||||
where
|
||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||
cmd c = io $ void $ callMethod c busname path iface mem
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Dependency Testing
|
||||
--
|
||||
-- Here we test all dependencies and keep the tree structure so we can print it
|
||||
-- for diagnostic purposes. This obviously has overlap with feature evaluation
|
||||
-- since we need to resolve dependencies to build each feature.
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Printing
|
||||
|
||||
-- printMsgs :: LogLevel -> [Msg] -> IO ()
|
||||
-- printMsgs lvl ms = do
|
||||
-- pn <- getProgName
|
||||
-- mapM_ (printMsg pn lvl) ms
|
||||
dumpSubfeatureRoot :: SubfeatureRoot a -> IO (JSONUnquotable, Bool)
|
||||
dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } =
|
||||
first (jsonSubfeature $ Q n) <$> dumpRoot r
|
||||
|
||||
-- printMsg :: String -> LogLevel -> Msg -> IO ()
|
||||
-- printMsg pname lvl (Msg ml mn msg)
|
||||
-- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
|
||||
-- | otherwise = skip
|
||||
-- where
|
||||
-- bracket s = "[" ++ s ++ "]"
|
||||
dumpRoot :: Root a -> IO (JSONUnquotable, Bool)
|
||||
dumpRoot (IORoot _ t) = first jsonIORoot <$>
|
||||
dumpTree testIODependency testIODependency_ dataIODependency dataIODependency_ t
|
||||
dumpRoot (IORoot_ _ t) = first jsonIORoot <$>
|
||||
dumpTree_ testIODependency_ dataIODependency_ t
|
||||
dumpRoot (DBusRoot _ t (Just cl)) = first jsonDBusRoot <$>
|
||||
dumpTree testIODependency (testDBusDependency_ cl) dataIODependency dataDBusDependency t
|
||||
dumpRoot (DBusRoot_ _ t (Just cl)) = first jsonDBusRoot <$>
|
||||
dumpTree_ (testDBusDependency_ cl) dataDBusDependency t
|
||||
-- TODO somehow return a message here that these failed
|
||||
dumpRoot (DBusRoot _ t Nothing) =
|
||||
return (jsonDBusRoot $ dataTree dataIODependency dataDBusDependency t, False)
|
||||
dumpRoot (DBusRoot_ _ t Nothing) =
|
||||
return (jsonDBusRoot $ dataTree_ dataDBusDependency t, False)
|
||||
|
||||
dumpTree :: (d p -> IO (Result p)) -> (d_ -> IO Result_)
|
||||
-> (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p
|
||||
-> IO (JSONUnquotable, Bool)
|
||||
dumpTree test test_ dd dd_ = go
|
||||
where
|
||||
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
|
||||
go (Or a b) = do
|
||||
(sa, ra) <- go a
|
||||
let j = jsonOr sa
|
||||
if ra then return (j $ data' b, ra) else first j <$> go b
|
||||
go (Only d) = do
|
||||
r <- fromResult <$> test d
|
||||
let (x, y) = dd d
|
||||
return (jsonLeaf (Just r) x y, fst r)
|
||||
dump_' = dumpTree_ test_ dd_
|
||||
data' = dataTree dd dd_
|
||||
doAnd fa fb fb_ a b = do
|
||||
(sa, ra) <- fa a
|
||||
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_ test_ dd_ = go
|
||||
where
|
||||
go (And_ a b) = do
|
||||
(sa, ra) <- go a
|
||||
let j = jsonAnd sa
|
||||
if ra then first j <$> go b else return (j $ dataTree_ dd_ b, ra)
|
||||
go (Or_ a b) = do
|
||||
(sa, ra) <- go a
|
||||
let j = jsonAnd sa
|
||||
if ra then return (j $ dataTree_ dd_ b, ra) else first j <$> go b
|
||||
go (Only_ d) = do
|
||||
r <- fromResult_ <$> test_ d
|
||||
let (x, y) = dd_ d
|
||||
return (jsonLeaf (Just r) x y, fst r)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Dependency data for JSON
|
||||
|
||||
type DependencyData = (JSONQuotable, [(String, JSONMixed)])
|
||||
|
||||
dataSubfeatureRoot :: SubfeatureRoot a -> JSONUnquotable
|
||||
dataSubfeatureRoot Subfeature { sfData = r, sfName = n } =
|
||||
jsonSubfeature (Q n) $ dataRoot r
|
||||
|
||||
dataRoot :: Root a -> JSONUnquotable
|
||||
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
|
||||
dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
|
||||
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
||||
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
||||
|
||||
dataTree :: (d p -> DependencyData) -> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable
|
||||
dataTree f f_ = go
|
||||
where
|
||||
go (And12 _ a b) = jsonAnd (go a) (go b)
|
||||
go (And1 a b) = jsonAnd (go a) (dataTree_ f_ b)
|
||||
go (And2 a b) = jsonAnd (dataTree_ f_ a) (go b)
|
||||
go (Or a b) = jsonOr (go a) (go b)
|
||||
go (Only d) = uncurry jsonLeafUntested $ f d
|
||||
|
||||
dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> JSONUnquotable
|
||||
dataTree_ f_ = go
|
||||
where
|
||||
go (And_ a b) = jsonAnd (go a) (go b)
|
||||
go (Or_ a b) = jsonOr (go a) (go b)
|
||||
go (Only_ d) = uncurry jsonLeafUntested $ f_ d
|
||||
|
||||
dataIODependency :: IODependency p -> DependencyData
|
||||
dataIODependency d = case d of
|
||||
(IORead n _) -> (Q "ioread", [("desc", JSON_Q $ Q n)])
|
||||
-- TODO make this actually useful (I actually need to name my features)
|
||||
(IOSometimes _ _) -> (Q "sometimes", [])
|
||||
(IOAlways _ _) -> (Q "always", [])
|
||||
|
||||
dataIODependency_ :: IODependency_ -> DependencyData
|
||||
dataIODependency_ d = case d of
|
||||
(IOSystem_ s) -> dataSysDependency s
|
||||
(IOSometimes_ _) -> (Q "sometimes", [])
|
||||
|
||||
dataSysDependency :: SystemDependency -> DependencyData
|
||||
dataSysDependency d = do
|
||||
case d of
|
||||
(Executable sys path) -> (Q "executable", [ ("system", JSON_UQ $ jsonBool sys)
|
||||
, ("path", JSON_Q $ Q path)
|
||||
])
|
||||
(IOTest desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)])
|
||||
(AccessiblePath p r w) -> (Q "path", [ ("path", JSON_Q $ Q p)
|
||||
, ("readable", JSON_UQ $ jsonBool r)
|
||||
, ("writable", JSON_UQ $ jsonBool w)
|
||||
])
|
||||
(Systemd t n) -> (Q "systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
|
||||
, ("unit", JSON_Q $ Q n)])
|
||||
|
||||
dataDBusDependency :: DBusDependency_ -> DependencyData
|
||||
dataDBusDependency d =
|
||||
case d of
|
||||
(DBusIO i) -> dataIODependency_ i
|
||||
(Bus b) -> (Q "bus", [("busname", JSON_Q $ Q $ formatBusName b)])
|
||||
(Endpoint b o i m) -> let (mt, mn) = memberData m
|
||||
in (Q "endpoint", [ ("busname", JSON_Q $ Q $ formatBusName b)
|
||||
, ("objectpath", JSON_Q $ Q $ formatObjectPath o)
|
||||
, ("interface", JSON_Q $ Q $ formatInterfaceName i)
|
||||
, ("membertype", JSON_Q $ Q mt)
|
||||
, ("membername", JSON_Q $ Q mn)
|
||||
])
|
||||
where
|
||||
memberData (Method_ n) = ("method", formatMemberName n)
|
||||
memberData (Signal_ n) = ("signal", formatMemberName n)
|
||||
memberData (Property_ n) = ("property", n)
|
||||
|
||||
fromResult :: Result a -> (Bool, [JSONQuotable])
|
||||
fromResult = second (fmap Q) . either (False,) (\(PostPass _ ws) -> (True, ws))
|
||||
|
||||
fromResult_ :: Result_ -> (Bool, [JSONQuotable])
|
||||
fromResult_ = second (fmap Q) . either (False,) (True,)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | JSON formatting
|
||||
--
|
||||
-- I could use Aeson...but I don't feel like it (too many intermediate types)
|
||||
|
||||
newtype JSONQuotable = Q String
|
||||
|
||||
newtype JSONUnquotable = UQ String
|
||||
|
||||
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
|
||||
|
||||
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||
-> JSONUnquotable
|
||||
jsonAlways = jsonFeature True
|
||||
|
||||
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
||||
-> JSONUnquotable
|
||||
jsonSometimes = jsonFeature False
|
||||
|
||||
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||
-> [JSONUnquotable] -> JSONUnquotable
|
||||
jsonFeature isalways success failed untested = jsonObject
|
||||
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
|
||||
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
|
||||
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
|
||||
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
|
||||
]
|
||||
|
||||
jsonSubfeature :: JSONQuotable -> JSONUnquotable -> JSONUnquotable
|
||||
jsonSubfeature n r = jsonObject
|
||||
[ ("name", JSON_Q n)
|
||||
, ("root", JSON_UQ r)
|
||||
]
|
||||
|
||||
jsonIORoot :: JSONUnquotable -> JSONUnquotable
|
||||
jsonIORoot = jsonRoot True
|
||||
|
||||
jsonDBusRoot :: JSONUnquotable -> JSONUnquotable
|
||||
jsonDBusRoot = jsonRoot False
|
||||
|
||||
jsonRoot :: Bool -> JSONUnquotable -> JSONUnquotable
|
||||
jsonRoot isIO tree = jsonObject
|
||||
[ ("type", JSON_Q $ Q $ if isIO then "io" else "dbus")
|
||||
, ("tree", JSON_UQ tree)
|
||||
]
|
||||
|
||||
jsonLeafUntested :: JSONQuotable -> [(String, JSONMixed)] -> JSONUnquotable
|
||||
jsonLeafUntested = jsonLeaf Nothing
|
||||
|
||||
jsonLeaf :: Maybe (Bool, [JSONQuotable]) -> JSONQuotable -> [(String, JSONMixed)]
|
||||
-> JSONUnquotable
|
||||
jsonLeaf status deptype depdata = jsonObject
|
||||
[ ("type", JSON_Q deptype)
|
||||
, ("status", jsonMaybe (JSON_UQ . uncurry jsonStatus) status)
|
||||
, ("data", JSON_UQ $ jsonObject depdata)
|
||||
]
|
||||
|
||||
jsonStatus :: Bool -> [JSONQuotable] -> JSONUnquotable
|
||||
jsonStatus present messages = jsonObject
|
||||
[ ("present", JSON_UQ $ jsonBool present)
|
||||
, ("messages", JSON_UQ $ jsonArray $ fmap JSON_Q messages)
|
||||
]
|
||||
|
||||
jsonAnd :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||
jsonAnd = jsonBranch True
|
||||
|
||||
jsonOr :: JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||
jsonOr = jsonBranch False
|
||||
|
||||
jsonBranch :: Bool -> JSONUnquotable -> JSONUnquotable -> JSONUnquotable
|
||||
jsonBranch isAnd l r = jsonObject
|
||||
[ ("test", JSON_Q $ Q $ if isAnd then "and" else "or")
|
||||
, ("left", JSON_UQ l)
|
||||
, ("right",JSON_UQ r)
|
||||
]
|
||||
|
||||
jsonMaybe :: (a -> JSONMixed) -> Maybe a -> JSONMixed
|
||||
jsonMaybe = maybe (JSON_UQ $ UQ "null")
|
||||
|
||||
jsonBool :: Bool -> JSONUnquotable
|
||||
jsonBool True = UQ "true"
|
||||
jsonBool False = UQ "false"
|
||||
|
||||
jsonArray :: [JSONMixed] -> JSONUnquotable
|
||||
jsonArray = UQ . bracket . intercalate "," . fmap quoteMaybe
|
||||
|
||||
jsonObject :: [(String, JSONMixed)] -> JSONUnquotable
|
||||
jsonObject = UQ . curly . intercalate ","
|
||||
. fmap (\(k, v) -> doubleQuote k ++ ":" ++ quoteMaybe v)
|
||||
|
||||
quoteMaybe :: JSONMixed -> String
|
||||
quoteMaybe (JSON_Q (Q s)) = doubleQuote s
|
||||
quoteMaybe (JSON_UQ (UQ s)) = s
|
||||
|
||||
bracket :: String -> String
|
||||
bracket s = "[" ++ s ++ "]"
|
||||
|
||||
quote :: String -> String
|
||||
quote s = "'" ++ s ++ "'"
|
||||
curly :: String -> String
|
||||
curly s = "{" ++ s ++ "}"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Other random formatting
|
||||
|
||||
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
||||
failedMsgs err = fmap concat . mapM (failedMsg err)
|
||||
|
|
@ -594,3 +838,4 @@ fmtMsg err n msg = do
|
|||
let e = if err then "ERROR" else "WARNING"
|
||||
p <- getProgName
|
||||
return $ unwords [bracket p, bracket e, bracket n, msg]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue