ENH only print packages from dep tree
This commit is contained in:
parent
05c6963fbd
commit
ee5cb9877d
|
|
@ -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 ()
|
||||||
|
|
|
||||||
|
|
@ -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])
|
||||||
|
|
|
||||||
|
|
@ -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 ++ "}"
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue