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

ENH only print packages from dep tree

This commit is contained in:
Nathan Dwarshuis 2022-12-25 18:07:03 -05:00
parent 05c6963fbd
commit ee5cb9877d
3 changed files with 104 additions and 280 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
bin/xmobar.hs
View File

@ -77,9 +77,8 @@ evalConfig db = do
printDeps :: FIO () printDeps :: FIO ()
printDeps = do printDeps = do
db <- io connectDBus db <- io connectDBus
fs <- mapM dumpFeature $ allFeatures db let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
let (UQ u) = jsonArray $ fmap JSON_UQ fs io $ mapM_ putStrLn ps
io $ putStrLn u
io $ disconnectDBus db io $ disconnectDBus db
usage :: IO () usage :: IO ()

10
bin/xmonad.hs
View File

@ -177,11 +177,11 @@ printDeps :: FIO ()
printDeps = do printDeps = do
db <- io connectDBus db <- io connectDBus
(i, f, d) <- allFeatures db (i, f, d) <- allFeatures db
is <- mapM dumpSometimes i let is = concatMap dumpSometimes i
fs <- mapM dumpFeature f let fs = concatMap dumpFeature f
ds <- mapM dumpSometimes d let ds = concatMap dumpSometimes d
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
io $ putStrLn u io $ mapM_ putStrLn ps
io $ disconnectDBus db io $ disconnectDBus db
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])

369
lib/Data/Internal/Dependency.hs
View File

@ -3,7 +3,6 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Functions for handling dependencies -- | Functions for handling dependencies
@ -55,10 +54,7 @@ module Data.Internal.Dependency
, dumpFeature , dumpFeature
, dumpAlways , dumpAlways
, dumpSometimes , dumpSometimes
, jsonArray , showFulfillment
, JSONQuotable(..)
, JSONUnquotable(..)
, JSONMixed(..)
-- testing -- testing
, FIO , FIO
@ -200,35 +196,21 @@ printMsg (FMsg fn n (Msg ll m)) = do
++ [m] ++ [m]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature status -- | Package status
-- | Dump the status of a Feature showFulfillment :: Fulfillment -> String
dumpFeature :: Feature a -> FIO JSONUnquotable showFulfillment (Package t n) = show t ++ "\t" ++ n
dumpFeature :: Feature a -> [Fulfillment]
dumpFeature = either dumpSometimes dumpAlways dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout dumpAlways :: Always a -> [Fulfillment]
dumpAlways :: Always a -> FIO JSONUnquotable dumpAlways (Always _ x) = case x of
dumpAlways (Always n x) = go [] x (Option o _) -> nub $ dataSubfeatureRoot o
where _ -> []
go failed (Option o os) = do
(s, r) <- dumpSubfeatureRoot o
if r
then return $ jsonAlways (Q n) (Just s) failed $ untested [] os
else go (s:failed) os
go failed (Always_ _) = return $ jsonAlways (Q n) (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 :: Sometimes a -> [Fulfillment]
dumpSometimes :: Sometimes a -> FIO JSONUnquotable dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
dumpSometimes (Sometimes n _ a) = go [] a
where
go failed [] = return $ jsonSometimes (Q n) Nothing failed []
go failed (x:xs) = do
(s, r) <- dumpSubfeatureRoot x
if r
then return $ jsonSometimes (Q n) (Just s) failed $ fmap dataSubfeatureRoot xs
else go (s:failed) xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Wrapper types -- | Wrapper types
@ -389,12 +371,12 @@ instance Hashable DBusMember where
-- TODO there is a third type of package: not in aur or official -- TODO there is a third type of package: not in aur or official
-- | A means to fulfill a dependency -- | A means to fulfill a dependency
-- For now this is just the name of an Arch Linux package (AUR or official) -- For now this is just the name of an Arch Linux package (AUR or official)
data Fulfillment = Package ArchPkg String deriving (Eq, Show) data Fulfillment = Package ArchPkg String deriving (Eq, Show, Ord)
instance Hashable Fulfillment where instance Hashable Fulfillment where
hashWithSalt s (Package a n) = s `hashWithSalt` a `hashWithSalt` n hashWithSalt s (Package a n) = s `hashWithSalt` a `hashWithSalt` n
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
instance Hashable ArchPkg instance Hashable ArchPkg
@ -1070,277 +1052,120 @@ process ful = IOSystem_ ful . Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing -- | Printing
dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (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 -> FIO (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 <$>
dumpTree_ testIODependency_ dataIODependency_ t -- dumpTree_ testIODependency_ dataIODependency_ t
dumpRoot (DBusRoot _ t (Just cl)) = first jsonDBusRoot <$> -- dumpRoot (DBusRoot _ t (Just cl)) = first jsonDBusRoot <$>
dumpTree testIODependency (testDBusDependency_ cl) dataIODependency dataDBusDependency t -- dumpTree testIODependency (testDBusDependency_ cl) dataIODependency dataDBusDependency t
dumpRoot (DBusRoot_ _ t (Just cl)) = first jsonDBusRoot <$> -- dumpRoot (DBusRoot_ _ t (Just cl)) = first jsonDBusRoot <$>
dumpTree_ (testDBusDependency_ cl) dataDBusDependency t -- dumpTree_ (testDBusDependency_ cl) dataDBusDependency t
-- TODO somehow return a message here that these failed -- -- TODO somehow return a message here that these failed
dumpRoot (DBusRoot _ t Nothing) = -- dumpRoot (DBusRoot _ t Nothing) =
return (jsonDBusRoot $ dataTree dataIODependency dataDBusDependency t, False) -- return (jsonDBusRoot $ dataTree dataIODependency dataDBusDependency t, False)
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 -> FIO (Result q)) -- dumpTree :: forall d d_ p. (forall q. d q -> FIO (Result q))
-> (d_ -> FIO Result_) -> (forall q. d q -> DependencyData) -- -> (d_ -> FIO Result_) -> (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> FIO (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 -> FIO (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
go (Or a b) = do -- go (Or a b) = do
(sa, ra) <- go a -- (sa, ra) <- go a
let j = jsonOr sa -- let j = jsonOr sa
if ra then return (j $ data' b, ra) else first j <$> go b -- if ra then return (j $ data' b, ra) else first j <$> go b
go (Only d) = do -- go (Only d) = do
r <- fromResult <$> test d -- r <- fromResult <$> test d
let (x, y) = dd d -- let (x, y) = dd d
return (jsonLeaf (Just r) x y, fst r) -- return (jsonLeaf (Just r) x y, fst r)
data' :: forall q. Tree d d_ q -> JSONUnquotable -- data' :: forall q. Tree d d_ q -> JSONUnquotable
data' = dataTree dd dd_ -- data' = dataTree dd dd_
dump_' = dumpTree_ test_ dd_ -- dump_' = dumpTree_ test_ dd_
doAnd fa fb fb_ a b = do -- doAnd fa fb fb_ a b = do
(sa, ra) <- fa a -- (sa, ra) <- fa a
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_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_ -- dumpTree_ :: (d_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_
-> FIO (JSONUnquotable, Bool) -- -> FIO (DependencyData, Bool)
dumpTree_ test_ dd_ = go -- dumpTree_ test_ dd_ = go
where -- where
go (And_ a b) = do -- go (And_ a b) = do
(sa, ra) <- go a -- (sa, ra) <- go a
let j = jsonAnd sa -- let j = jsonAnd sa
if ra then first j <$> go b else return (j $ dataTree_ dd_ b, ra) -- if ra then first j <$> go b else return (j $ dataTree_ dd_ b, ra)
go (Or_ a b) = do -- go (Or_ a b) = do
(sa, ra) <- go a -- (sa, ra) <- go a
let j = jsonAnd sa -- let j = jsonAnd sa
if ra then return (j $ dataTree_ dd_ b, ra) else first j <$> go b -- if ra then return (j $ dataTree_ dd_ b, ra) else first j <$> go b
go (Only_ d) = do -- go (Only_ d) = do
r <- fromResult_ <$> test_ d -- r <- test_ d
let (x, y) = dd_ d -- return (dd_ d, isRight r)
return (jsonLeaf (Just r) x y, fst r)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency data for JSON -- | Dependency data for JSON
type DependencyData = (JSONQuotable, [(String, JSONMixed)]) type DependencyData = [Fulfillment]
dataSubfeatureRoot :: SubfeatureRoot a -> JSONUnquotable dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData
dataSubfeatureRoot Subfeature { sfData = r, sfName = n } = dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r
jsonSubfeature (Q n) $ dataRoot r
dataRoot :: Root a -> JSONUnquotable dataRoot :: Root a -> DependencyData
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
dataTree :: forall d d_ p. (forall q. d q -> DependencyData) dataTree :: forall d d_ p. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData) -> Tree d d_ p -> JSONUnquotable -> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData
dataTree f f_ = go dataTree f f_ = go
where where
go :: forall q. Tree d d_ q -> JSONUnquotable go :: forall q. Tree d d_ q -> DependencyData
go (And12 _ a b) = jsonAnd (go a) (go b) go (And12 _ a b) = go a ++ go b
go (And1 a b) = jsonAnd (go a) (dataTree_ f_ b) go (And1 a b) = go a ++ dataTree_ f_ b
go (And2 a b) = jsonAnd (dataTree_ f_ a) (go b) go (And2 a b) = dataTree_ f_ a ++ go b
go (Or a b) = jsonOr (go a) (go b) go (Or a _) = go a
go (Only d) = uncurry jsonLeafUntested $ f d go (Only d) = f d
dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> JSONUnquotable dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData
dataTree_ f_ = go dataTree_ f_ = go
where where
go (And_ a b) = jsonAnd (go a) (go b) go (And_ a b) = go a ++ go b
go (Or_ a b) = jsonOr (go a) (go b) go (Or_ a _) = go a
go (Only_ d) = uncurry jsonLeafUntested $ f_ d go (Only_ d) = f_ d
dataIODependency :: IODependency p -> DependencyData dataIODependency :: IODependency p -> DependencyData
dataIODependency d = first Q $ case d of dataIODependency d = case d of
(IORead n f _) -> ("ioread", [ ("desc", JSON_Q $ Q n) (IORead _ f _) -> f
, ("fulfillment", JSON_UQ (IOSometimes x _) -> dumpSometimes x
$ dataFulfillments f) (IOAlways x _) -> dumpAlways x
]) _ -> []
(IOConst _) -> ("const", [])
-- TODO what if this isn't required?
(IOSometimes (Sometimes n _ _) _) -> ("sometimes", [ ("name", JSON_Q $ Q n)])
(IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)])
dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of dataIODependency_ d = case d of
(IOSystem_ f s) -> dataSysDependency f s (IOSystem_ f _) -> f
(IOSometimes_ _) -> (Q "sometimes", []) (IOTest_ _ f _) -> f
(IOTest_ desc f _) -> (Q "iotest", [ ("desc", JSON_Q $ Q desc) (IOSometimes_ x) -> dumpSometimes x
, ("fulfillment", JSON_UQ $ dataFulfillments f)
])
dataSysDependency :: [Fulfillment] -> SystemDependency -> DependencyData
dataSysDependency f d = first Q $
case d of
(Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys)
, ("path", JSON_Q $ Q path)
, f'
])
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
, ("readable", JSON_UQ $ jsonBool r)
, ("writable", JSON_UQ $ jsonBool w)
, f'
])
(Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t)
, ("unit", JSON_Q $ Q n)
, f'
])
(Process n) -> ("process", [("name", JSON_Q $ Q n), f'])
where
f' = ("fulfillment", JSON_UQ $ dataFulfillments f)
dataDBusDependency :: DBusDependency_ c -> DependencyData dataDBusDependency :: DBusDependency_ c -> DependencyData
dataDBusDependency d = dataDBusDependency d = case d of
case d of (Bus f _) -> f
(DBusIO i) -> dataIODependency_ i (Endpoint f _ _ _ _) -> f
(Bus f b) -> (Q "bus", [ ("busname", JSON_Q $ Q $ formatBusName b) (DBusIO x) -> dataIODependency_ x
, ("fulfillment", JSON_UQ $ dataFulfillments f)
])
(Endpoint f 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)
, ("fulfillment", JSON_UQ $ dataFulfillments f)
])
where
memberData (Method_ n) = ("method", formatMemberName n)
memberData (Signal_ n) = ("signal", formatMemberName n)
memberData (Property_ n) = ("property", n)
dataFulfillments :: [Fulfillment] -> JSONUnquotable
dataFulfillments = jsonArray . fmap (JSON_UQ . dataFulfillment)
dataFulfillment :: Fulfillment -> JSONUnquotable
dataFulfillment (Package a n) = jsonObject [ ("type", JSON_Q $ Q "package")
, ("type", JSON_Q $ Q $ show a)
, ("name", JSON_Q $ Q n)
]
fromMsg :: Msg -> JSONUnquotable
fromMsg (Msg e s) = jsonObject [ ("level", JSON_Q $ Q $ show e)
, ("msg", JSON_Q $ Q s)
]
fromResult :: Result a -> (Bool, [JSONUnquotable])
fromResult = second (fmap fromMsg) . either (False,) (\(PostPass _ ws) -> (True, ws))
fromResult_ :: Result_ -> (Bool, [JSONUnquotable])
fromResult_ = second (fmap fromMsg) . either (False,) (True,)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | JSON formatting -- | 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 :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
jsonAlways = jsonFeature True
jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
jsonSometimes = jsonFeature False
jsonFeature :: Bool -> JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
jsonFeature isalways name success failed untested = jsonObject
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
, ("name", JSON_Q name)
, ("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, [JSONUnquotable]) -> 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 -> [JSONUnquotable] -> JSONUnquotable
jsonStatus present messages = jsonObject
[ ("present", JSON_UQ $ jsonBool present)
, ("messages", JSON_UQ $ jsonArray $ fmap JSON_UQ 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 :: String -> String
bracket s = "[" ++ s ++ "]" bracket s = "[" ++ s ++ "]"
curly :: String -> String
curly s = "{" ++ s ++ "}"