From ee5cb9877d7d0b18980bac32c41ad404523341f1 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 25 Dec 2022 18:07:03 -0500 Subject: [PATCH] ENH only print packages from dep tree --- bin/xmobar.hs | 5 +- bin/xmonad.hs | 10 +- lib/Data/Internal/Dependency.hs | 369 +++++++++----------------------- 3 files changed, 104 insertions(+), 280 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index c8eb509..72e0cda 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -77,9 +77,8 @@ evalConfig db = do printDeps :: FIO () printDeps = do db <- io connectDBus - fs <- mapM dumpFeature $ allFeatures db - let (UQ u) = jsonArray $ fmap JSON_UQ fs - io $ putStrLn u + let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db + io $ mapM_ putStrLn ps io $ disconnectDBus db usage :: IO () diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 765a229..6387878 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -177,11 +177,11 @@ printDeps :: FIO () printDeps = do 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 - io $ putStrLn u + let is = concatMap dumpSometimes i + let fs = concatMap dumpFeature f + let ds = concatMap dumpSometimes d + let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds + io $ mapM_ putStrLn ps io $ disconnectDBus db allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 6f30305..3f679f6 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -------------------------------------------------------------------------------- -- | Functions for handling dependencies @@ -55,10 +54,7 @@ module Data.Internal.Dependency , dumpFeature , dumpAlways , dumpSometimes - , jsonArray - , JSONQuotable(..) - , JSONUnquotable(..) - , JSONMixed(..) + , showFulfillment -- testing , FIO @@ -200,35 +196,21 @@ printMsg (FMsg fn n (Msg ll m)) = do ++ [m] -------------------------------------------------------------------------------- --- | Feature status +-- | Package status --- | Dump the status of a Feature -dumpFeature :: Feature a -> FIO JSONUnquotable +showFulfillment :: Fulfillment -> String +showFulfillment (Package t n) = show t ++ "\t" ++ n + +dumpFeature :: Feature a -> [Fulfillment] dumpFeature = either dumpSometimes dumpAlways --- | Dump the status of an Always to stdout -dumpAlways :: Always a -> FIO JSONUnquotable -dumpAlways (Always n x) = go [] x - 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 +dumpAlways :: Always a -> [Fulfillment] +dumpAlways (Always _ x) = case x of + (Option o _) -> nub $ dataSubfeatureRoot o + _ -> [] --- | Dump the status of a Sometimes to stdout -dumpSometimes :: Sometimes a -> FIO JSONUnquotable -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 +dumpSometimes :: Sometimes a -> [Fulfillment] +dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs -------------------------------------------------------------------------------- -- | Wrapper types @@ -389,12 +371,12 @@ instance Hashable DBusMember where -- TODO there is a third type of package: not in aur or official -- | A means to fulfill a dependency -- 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 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 @@ -1070,277 +1052,120 @@ process ful = IOSystem_ ful . Process -------------------------------------------------------------------------------- -- | Printing -dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (JSONUnquotable, Bool) -dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } = - first (jsonSubfeature $ Q n) <$> dumpRoot r +-- dumpSubfeatureRoot :: SubfeatureRoot a -> FIO (JSONUnquotable, Bool) +-- dumpSubfeatureRoot Subfeature { sfData = r, sfName = n } = +-- first (jsonSubfeature $ Q n) <$> dumpRoot r -dumpRoot :: Root a -> FIO (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) +-- dumpRoot :: Root a -> FIO (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 :: 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 -> 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 - 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) - data' :: forall q. Tree d d_ q -> JSONUnquotable - data' = dataTree dd dd_ - dump_' = dumpTree_ test_ 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 :: 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 -> 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 +-- 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) +-- data' :: forall q. Tree d d_ q -> JSONUnquotable +-- data' = dataTree dd dd_ +-- dump_' = dumpTree_ test_ 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_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_ - -> FIO (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) +-- dumpTree_ :: (d_ -> FIO Result_) -> (d_ -> DependencyData) -> Tree_ d_ +-- -> FIO (DependencyData, 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 <- test_ d +-- return (dd_ d, isRight r) -------------------------------------------------------------------------------- -- | Dependency data for JSON -type DependencyData = (JSONQuotable, [(String, JSONMixed)]) +type DependencyData = [Fulfillment] -dataSubfeatureRoot :: SubfeatureRoot a -> JSONUnquotable -dataSubfeatureRoot Subfeature { sfData = r, sfName = n } = - jsonSubfeature (Q n) $ dataRoot r +dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData +dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r -dataRoot :: Root a -> JSONUnquotable +dataRoot :: Root a -> DependencyData 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 :: 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 where - go :: forall q. Tree d d_ q -> JSONUnquotable - 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 + go :: forall q. Tree d d_ q -> DependencyData + go (And12 _ a b) = go a ++ go b + go (And1 a b) = go a ++ dataTree_ f_ b + go (And2 a b) = dataTree_ f_ a ++ go b + go (Or a _) = go a + go (Only d) = f d -dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> JSONUnquotable +dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData 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 + go (And_ a b) = go a ++ go b + go (Or_ a _) = go a + go (Only_ d) = f_ d dataIODependency :: IODependency p -> DependencyData -dataIODependency d = first Q $ case d of - (IORead n f _) -> ("ioread", [ ("desc", JSON_Q $ Q n) - , ("fulfillment", JSON_UQ - $ dataFulfillments f) - ]) - (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 d = case d of + (IORead _ f _) -> f + (IOSometimes x _) -> dumpSometimes x + (IOAlways x _) -> dumpAlways x + _ -> [] dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of - (IOSystem_ f s) -> dataSysDependency f s - (IOSometimes_ _) -> (Q "sometimes", []) - (IOTest_ desc f _) -> (Q "iotest", [ ("desc", JSON_Q $ Q desc) - , ("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) - + (IOSystem_ f _) -> f + (IOTest_ _ f _) -> f + (IOSometimes_ x) -> dumpSometimes x dataDBusDependency :: DBusDependency_ c -> DependencyData -dataDBusDependency d = - case d of - (DBusIO i) -> dataIODependency_ i - (Bus f b) -> (Q "bus", [ ("busname", JSON_Q $ Q $ formatBusName b) - , ("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,) +dataDBusDependency d = case d of + (Bus f _) -> f + (Endpoint f _ _ _ _) -> f + (DBusIO x) -> dataIODependency_ x -------------------------------------------------------------------------------- -- | 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 s = "[" ++ s ++ "]" -curly :: String -> String -curly s = "{" ++ s ++ "}"