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 = 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 ()
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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 ++ "}"
|
||||
|
|
|
|||
Loading…
Reference in New Issue