xmonad-config/lib/Data/Internal/Dependency.hs

1131 lines
34 KiB
Haskell
Raw Normal View History

2022-12-30 14:58:23 -05:00
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
2022-07-01 23:15:44 -04:00
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Functions for handling dependencies
2022-07-09 17:44:14 -04:00
module Data.Internal.Dependency
2022-12-30 14:58:23 -05:00
-- feature types
( Feature
2022-12-30 14:58:23 -05:00
, Always (..)
, Always_ (..)
, FallbackRoot (..)
, FallbackStack (..)
, Sometimes (..)
2022-06-28 23:27:55 -04:00
, Sometimes_
, AlwaysX
, AlwaysIO
, SometimesX
, SometimesIO
2022-12-30 14:58:23 -05:00
, PostPass (..)
, Subfeature (..)
2022-06-26 19:27:04 -04:00
, SubfeatureRoot
2022-12-30 14:58:23 -05:00
, Msg (..)
-- configuration
2022-12-30 14:58:23 -05:00
, XParams (..)
, XPFeatures (..)
, XPQuery
-- dependency tree types
2022-12-30 14:58:23 -05:00
, Root (..)
, Tree (..)
, Tree_ (..)
2022-07-02 17:09:21 -04:00
, IOTree
, IOTree_
, DBusTree
, DBusTree_
2022-12-30 14:58:23 -05:00
, SafeClient (..)
, IODependency (..)
, IODependency_ (..)
, SystemDependency (..)
, DBusDependency_ (..)
, DBusMember (..)
, UnitType (..)
, Result
2022-12-30 14:58:23 -05:00
, Fulfillment (..)
, ArchPkg (..)
2022-06-28 21:24:21 -04:00
-- dumping
, dumpFeature
, dumpAlways
, dumpSometimes
2022-12-25 18:07:03 -05:00
, showFulfillment
-- testing
, FIO
, withCache
, evalFeature
, executeSometimes
, executeAlways
, evalAlways
, evalSometimes
, fontTreeAlt
, fontTree
, fontTree_
, fontAlways
, fontSometimes
, readEthernet
, readWireless
2022-07-08 00:21:05 -04:00
, socketExists
-- lifting
2022-12-31 16:23:17 -05:00
-- , ioSometimes
-- , ioAlways
-- feature construction
, always1
, sometimes1
, sometimesIO
2022-07-02 17:09:21 -04:00
, sometimesIO_
, sometimesDBus
, sometimesExe
, sometimesExeArgs
, sometimesEndpoint
-- dependency construction
, sysExe
, localExe
, sysdSystem
, sysdUser
, listToAnds
, toAnd_
, toFallback
, pathR
, pathRW
, pathW
, voidResult
, voidRead
, process
2022-07-03 18:23:32 -04:00
-- misc
, shellTest
2022-12-30 14:58:23 -05:00
)
where
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key
import Data.Internal.DBus
import Data.Yaml
import GHC.IO.Exception (ioe_description)
import RIO hiding (bracket, fromString)
2022-12-31 19:04:37 -05:00
import RIO.Directory
2022-12-30 14:58:23 -05:00
import RIO.FilePath
2022-12-31 19:47:02 -05:00
import RIO.List
2022-12-30 14:58:23 -05:00
import RIO.Process hiding (findExecutable)
import qualified RIO.Text as T
import System.Posix.Files
import System.Process.Typed (nullStream)
2022-12-31 19:04:37 -05:00
import UnliftIO.Environment
2022-12-30 14:58:23 -05:00
import XMonad.Core (X, io)
import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Feature Evaluation
--
-- Here we attempt to build and return the monadic actions encoded by each
-- feature.
-- | Run feature evaluation(s) with the cache
-- Currently there is no easy way to not use this (oh well)
withCache :: FIO a -> IO a
2022-07-07 18:40:42 -04:00
withCache x = do
2022-12-26 17:56:55 -05:00
logOpts <- logOptionsHandle stderr False
2022-12-27 19:39:16 -05:00
pc <- mkDefaultProcessContext
2022-12-26 17:56:55 -05:00
withLogFunc logOpts $ \f -> do
p <- getParams
2022-12-27 19:39:16 -05:00
let s = DepStage f pc p
2022-12-26 17:56:55 -05:00
runRIO s x
-- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a
executeAlways = io <=< evalAlways
-- | Execute a Sometimes immediately (or do nothing if failure)
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-- | Possibly return the action of an Always/Sometimes
evalFeature :: Feature a -> FIO (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
2022-12-30 14:58:23 -05:00
evalFeature (Left s) = evalSometimes s
-- | Possibly return the action of a Sometimes
evalSometimes :: Sometimes a -> FIO (Maybe a)
evalSometimes x = either goFail goPass =<< evalSometimesMsg x
where
2022-07-07 01:05:17 -04:00
goPass (a, ws) = putErrors ws >> return (Just a)
goFail es = putErrors es >> return Nothing
2022-12-26 17:56:55 -05:00
putErrors = mapM_ logMsg
-- | Return the action of an Always
evalAlways :: Always a -> FIO a
evalAlways a = do
2022-07-07 01:05:17 -04:00
(x, ws) <- evalAlwaysMsg a
2022-12-26 17:56:55 -05:00
mapM_ logMsg ws
return x
2022-12-26 17:56:55 -05:00
logMsg :: FMsg -> FIO ()
logMsg (FMsg fn n (Msg ll m)) = do
p <- io getProgName
2022-12-26 17:56:55 -05:00
f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
where
2022-12-26 17:56:55 -05:00
llFun LevelError = ("ERROR", logError)
2022-12-30 14:58:23 -05:00
llFun LevelInfo = ("INFO", logInfo)
llFun LevelWarn = ("WARN", logWarn)
llFun _ = ("DEBUG", logDebug)
2022-12-26 17:56:55 -05:00
(s, f) = llFun ll
2022-12-30 14:58:23 -05:00
fmt p l =
[ bracket p
, bracket l
, bracket fn
]
++ maybe [] ((: []) . bracket) n
++ [m]
2022-07-07 01:05:17 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Package status
showFulfillment :: Fulfillment -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
2022-12-25 18:07:03 -05:00
dumpFeature :: Feature a -> [Fulfillment]
2022-06-28 21:24:21 -04:00
dumpFeature = either dumpSometimes dumpAlways
2022-12-25 18:07:03 -05:00
dumpAlways :: Always a -> [Fulfillment]
dumpAlways (Always _ x) = case x of
(Option o _) -> nub $ dataSubfeatureRoot o
2022-12-30 14:58:23 -05:00
_ -> []
2022-12-25 18:07:03 -05:00
dumpSometimes :: Sometimes a -> [Fulfillment]
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
2021-11-11 00:11:15 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Wrapper types
2021-11-20 01:15:04 -05:00
type AlwaysX = Always (X ())
type AlwaysIO = Always (IO ())
type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (FIO ())
type Feature a = Either (Sometimes a) (Always a)
2021-11-22 23:46:51 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Feature declaration
-- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail
-- the fallback is a monadic action (eg a plain haskell function)
data Always a = Always T.Text (Always_ a)
2022-06-28 23:27:55 -04:00
-- | Feature that is guaranteed to work (inner data)
2022-12-30 14:58:23 -05:00
data Always_ a
= Option (SubfeatureRoot a) (Always_ a)
2022-07-02 17:09:21 -04:00
| Always_ (FallbackRoot a)
-- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results
-- from other Always features.
2022-12-30 14:58:23 -05:00
data FallbackRoot a
= FallbackAlone a
2022-07-02 17:09:21 -04:00
| forall p. FallbackTree (p -> a) (FallbackStack p)
-- | Always features that are used as a payload for a fallback action
2022-12-30 14:58:23 -05:00
data FallbackStack p
= FallbackBottom (Always p)
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
-- | Feature that might not be present
-- This is like an Always except it doesn't fall back on a guaranteed monadic
-- action
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
2022-06-28 23:27:55 -04:00
-- | Feature that might not be present (inner data)
type Sometimes_ a = [SubfeatureRoot a]
-- | Individually tested sub-feature data for Always/sometimes
-- The polymorphism allows representing tested and untested states. Includes
-- the 'action' itself to be tested and any auxilary data for describing the
-- sub-feature.
data Subfeature f = Subfeature
{ sfData :: f
, sfName :: T.Text
}
2022-07-07 18:40:42 -04:00
type SubfeatureRoot a = Subfeature (Root a)
-- | An action and its dependencies
-- May be a plain old monad or be DBus-dependent, in which case a client is
-- needed
2022-12-30 14:58:23 -05:00
data Root a
= forall p. IORoot (p -> a) (IOTree p)
2022-07-02 17:09:21 -04:00
| IORoot_ a IOTree_
2022-07-09 17:08:10 -04:00
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
2022-07-02 17:09:21 -04:00
-- | The dependency tree with rule to merge results when needed
2022-12-30 14:58:23 -05:00
data Tree d d_ p
= forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
2022-06-26 20:48:26 -04:00
| And1 (Tree d d_ p) (Tree_ d_)
| And2 (Tree_ d_) (Tree d d_ p)
| Or (Tree d d_ p) (Tree d d_ p)
| Only (d p)
-- | A dependency tree without functions to merge results
2022-07-02 17:09:21 -04:00
data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-- | Shorthand tree types for lazy typers
type IOTree p = Tree IODependency IODependency_ p
2022-12-30 14:58:23 -05:00
2022-07-09 17:08:10 -04:00
type DBusTree c p = Tree IODependency (DBusDependency_ c) p
2022-12-30 14:58:23 -05:00
2022-07-02 17:09:21 -04:00
type IOTree_ = Tree_ IODependency_
2022-12-30 14:58:23 -05:00
2022-07-09 17:08:10 -04:00
type DBusTree_ c = Tree_ (DBusDependency_ c)
2022-07-03 18:23:32 -04:00
-- | A dependency that only requires IO to evaluate (with payload)
2022-12-30 14:58:23 -05:00
data IODependency p
= -- an IO action that yields a payload
IORead T.Text [Fulfillment] (FIO (Result p))
| -- always yields a payload
IOConst p
| -- an always that yields a payload
forall a. IOAlways (Always a) (a -> p)
| -- a sometimes that yields a payload
forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus
2022-12-30 14:58:23 -05:00
data DBusDependency_ c
= Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_
2022-12-26 10:44:03 -05:00
deriving (Generic)
2021-11-21 10:26:28 -05:00
-- | A dependency that only requires IO to evaluate (no payload)
2022-12-30 14:58:23 -05:00
data IODependency_
= IOSystem_ [Fulfillment] SystemDependency
2022-12-27 19:39:16 -05:00
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
2022-06-26 19:27:04 -04:00
| forall a. IOSometimes_ (Sometimes a)
2022-07-03 18:23:32 -04:00
-- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious
2022-12-30 14:58:23 -05:00
data SystemDependency
= Executable Bool FilePath
2021-11-21 10:26:28 -05:00
| AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text
| Process T.Text
deriving (Eq, Show, Generic)
-- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
-- | Wrapper type to describe and endpoint
2022-12-30 14:58:23 -05:00
data DBusMember
= Method_ MemberName
2021-11-22 23:46:51 -05:00
| Signal_ MemberName
| Property_ T.Text
deriving (Eq, Show, Generic)
-- | 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 T.Text deriving (Eq, Show, Ord)
2022-12-25 18:07:03 -05:00
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
2021-11-22 23:46:51 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Tested dependency tree
2021-11-21 10:26:28 -05:00
--
-- The main reason I need this is so I have a "result" I can convert to JSON
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
2022-07-07 01:05:17 -04:00
-- | A message with criteria for when to show it
data Msg = Msg LogLevel T.Text
2022-07-07 01:05:17 -04:00
-- | A message annotated with subfeature and feature name
data FMsg = FMsg T.Text (Maybe T.Text) Msg
2022-07-07 01:05:17 -04:00
-- | Tested Always feature
2022-12-30 14:58:23 -05:00
data PostAlways a
= Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail]
-- | Tested Sometimes feature
data PostSometimes a = PostSometimes
{ psSuccess :: Maybe (SubfeaturePass a)
2022-12-30 14:58:23 -05:00
, psFailed :: [SubfeatureFail]
}
-- | Passing subfeature
type SubfeaturePass a = Subfeature (PostPass a)
-- | Failed subfeature
type SubfeatureFail = Subfeature PostFail
-- | An action that passed
2022-07-07 01:05:17 -04:00
data PostPass a = PostPass a [Msg] deriving (Functor)
2022-07-07 01:05:17 -04:00
addMsgs :: PostPass a -> [Msg] -> PostPass a
addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed
2022-07-07 01:05:17 -04:00
data PostFail = PostFail [Msg] | PostMissing Msg
2022-07-07 18:40:42 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Configuration
2022-07-07 18:40:42 -04:00
2022-12-26 17:56:55 -05:00
type FIO a = RIO DepStage a
data DepStage = DepStage
2022-12-30 14:58:23 -05:00
{ dsLogFun :: !LogFunc
2022-12-27 19:39:16 -05:00
, dsProcCxt :: !ProcessContext
2022-12-30 14:58:23 -05:00
, dsParams :: !XParams
2022-12-26 17:56:55 -05:00
}
instance HasLogFunc DepStage where
2022-12-30 14:58:23 -05:00
logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
2022-12-26 17:56:55 -05:00
2022-12-27 19:39:16 -05:00
instance HasProcessContext DepStage where
2022-12-30 14:58:23 -05:00
processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
2022-07-07 18:40:42 -04:00
data XParams = XParams
{ xpLogLevel :: LogLevel
, xpFeatures :: XPFeatures
}
2022-12-26 17:56:55 -05:00
data JLogLevel = Error | Warn | Debug | Info
deriving (Eq, Show, Ord, Generic)
2022-12-26 17:56:55 -05:00
instance FromJSON JLogLevel
instance FromJSON XParams where
parseJSON = withObject "parameters" $ \o -> do
ll <- mapLevel <$> o .: fromString "loglevel"
fs <- o .: fromString "features"
return $ XParams ll fs
2022-12-30 14:58:23 -05:00
where
mapLevel Info = LevelInfo
mapLevel Error = LevelError
mapLevel Warn = LevelWarn
mapLevel Debug = LevelDebug
data XPFeatures = XPFeatures
2022-12-30 14:58:23 -05:00
{ xpfOptimus :: Bool
, xpfVirtualBox :: Bool
, xpfXSANE :: Bool
, xpfEthernet :: Bool
, xpfWireless :: Bool
, xpfVPN :: Bool
, xpfBluetooth :: Bool
, xpfIntelBacklight :: Bool
, xpfClevoBacklight :: Bool
2022-12-30 14:58:23 -05:00
, xpfBattery :: Bool
, xpfF5VPN :: Bool
2022-07-07 18:40:42 -04:00
}
instance FromJSON XPFeatures where
2022-12-30 14:58:23 -05:00
parseJSON = withObject "features" $ \o ->
XPFeatures
<$> o
.:+ "optimus"
<*> o
.:+ "virtualbox"
<*> o
.:+ "xsane"
<*> o
.:+ "ethernet"
<*> o
.:+ "wireless"
<*> o
.:+ "vpn"
<*> o
.:+ "bluetooth"
<*> o
.:+ "intel_backlight"
<*> o
.:+ "clevo_backlight"
<*> o
.:+ "battery"
<*> o
.:+ "f5vpn"
2022-07-07 18:40:42 -04:00
defParams :: XParams
2022-12-30 14:58:23 -05:00
defParams =
XParams
{ xpLogLevel = LevelError
, xpFeatures = defXPFeatures
}
defXPFeatures :: XPFeatures
2022-12-30 14:58:23 -05:00
defXPFeatures =
XPFeatures
{ xpfOptimus = False
, xpfVirtualBox = False
, xpfXSANE = False
, xpfEthernet = False
, xpfWireless = False
, -- TODO this might be broken down into different flags (expressvpn, etc)
xpfVPN = False
, xpfBluetooth = False
, xpfIntelBacklight = False
, xpfClevoBacklight = False
, xpfBattery = False
, xpfF5VPN = False
}
2022-07-07 18:40:42 -04:00
type XPQuery = XPFeatures -> Bool
2022-12-31 19:04:37 -05:00
getParams :: MonadIO m => m XParams
2022-07-07 18:40:42 -04:00
getParams = do
p <- getParamFile
2022-12-31 19:04:37 -05:00
maybe (return defParams) (liftIO . decodeYaml) p
2022-07-07 18:40:42 -04:00
where
2022-12-30 14:58:23 -05:00
decodeYaml p =
either (\e -> print e >> return defParams) return
=<< decodeFileEither p
2022-07-07 18:40:42 -04:00
2022-12-31 19:04:37 -05:00
getParamFile :: MonadIO m => m (Maybe FilePath)
2022-07-07 18:40:42 -04:00
getParamFile = do
e <- lookupEnv "XDG_CONFIG_HOME"
parent <- case e of
Nothing -> fallback
Just path
| isRelative path -> fallback
| otherwise -> return path
let full = parent </> "xmonad.yml"
2022-12-31 19:04:37 -05:00
(\x -> if x then Just full else Nothing) <$> doesFileExist full
2022-07-07 18:40:42 -04:00
where
fallback = (</> ".config") <$> getHomeDirectory
(.:+) :: Object -> String -> Parser Bool
(.:+) o n = o .:? fromString n .!= False
2022-07-07 18:40:42 -04:00
2022-12-30 14:58:23 -05:00
infix 9 .:+
2022-07-07 18:40:42 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Testing pipeline
2022-07-07 01:05:17 -04:00
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do
2022-12-26 17:56:55 -05:00
r <- asks (u . xpFeatures . dsParams)
2022-12-30 14:58:23 -05:00
if not r
then return $ Left [dis n]
else do
PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
let fs' = failedMsgs n fs
return $ case s of
(Just p) -> Right $ second (++ fs') $ passActMsg n p
_ -> Left fs'
where
2022-12-26 17:56:55 -05:00
dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
2022-07-07 01:05:17 -04:00
evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
evalAlwaysMsg (Always n x) = do
r <- testAlways x
2022-07-07 01:05:17 -04:00
return $ case r of
2022-12-30 14:58:23 -05:00
(Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p
2022-07-07 01:05:17 -04:00
(Fallback act fs) -> (act, failedMsgs n fs)
passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg])
2022-12-30 14:58:23 -05:00
passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws)
2022-07-07 01:05:17 -04:00
failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg]
2022-07-07 01:05:17 -04:00
failedMsgs n = concatMap (failedMsg n)
failedMsg :: T.Text -> SubfeatureFail -> [FMsg]
2022-12-30 14:58:23 -05:00
failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
(PostFail es) -> f es
2022-07-07 01:05:17 -04:00
(PostMissing e) -> f [e]
where
f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
r <- testSubfeature fd
case r of
2022-12-30 14:58:23 -05:00
(Left l) -> go (l : failed) next
(Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
evalFallbackRoot :: FallbackRoot a -> FIO a
2022-12-30 14:58:23 -05:00
evalFallbackRoot (FallbackAlone a) = return a
evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
evalFallbackStack :: FallbackStack p -> FIO p
evalFallbackStack (FallbackBottom a) = evalAlways a
evalFallbackStack (FallbackStack f a as) = do
ps <- evalFallbackStack as
p <- evalAlways a
return $ f p ps
testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing [])
where
go ts [] = return ts
2022-12-30 14:58:23 -05:00
go ts (x : xs) = do
sf <- testSubfeature x
case sf of
2022-12-30 14:58:23 -05:00
(Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
2022-12-30 14:58:23 -05:00
testSubfeature sf@Subfeature {sfData = t} = do
t' <- testRoot t
-- monomorphism restriction :(
2022-12-30 14:58:23 -05:00
return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do
case r of
2022-12-30 14:58:23 -05:00
(IORoot a t) -> go a testIODep_ testIODep t
(IORoot_ a t) -> go_ a testIODep_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
2022-12-26 10:44:03 -05:00
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
2022-12-30 14:58:23 -05:00
_ ->
return $
Left $
PostMissing $
Msg LevelError "client not available"
where
2022-07-01 23:15:44 -04:00
-- rank N polymorphism is apparently undecidable...gross
2022-12-26 10:44:03 -05:00
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
2022-07-01 23:15:44 -04:00
bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Payloaded dependency testing
2022-07-07 01:05:17 -04:00
type Result p = Either [Msg] (PostPass p)
2022-12-26 10:44:03 -05:00
type MResult p = Memoized (Result p)
2022-12-30 14:58:23 -05:00
testTree
:: forall d d_ p
. (d_ -> FIO MResult_)
2022-12-26 10:44:03 -05:00
-> (forall q. d q -> FIO (MResult q))
-> Tree d d_ p
-> FIO (Either [Msg] (PostPass p))
testTree test_ test = go
where
2022-12-26 10:44:03 -05:00
go :: forall q. Tree d d_ q -> FIO (Result q)
2022-06-26 20:48:26 -04:00
go (And12 f a b) = do
ra <- go a
2022-06-26 20:48:26 -04:00
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
go (And1 a b) = do
ra <- go a
liftRight (\p -> fmap (addMsgs p) <$> testTree_ test_ b) ra
go (And2 a b) = do
ra <- testTree_ test_ a
2022-06-26 20:48:26 -04:00
liftRight (\wa -> fmap (`addMsgs` wa) <$> go b) ra
go (Or a b) = do
ra <- go a
2022-06-26 20:48:26 -04:00
either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra
2022-12-30 14:58:23 -05:00
go (Only a) = runMemoized =<< test a
and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
2022-06-26 20:48:26 -04:00
liftRight = either (return . Left)
2022-12-26 10:44:03 -05:00
testIODep :: IODependency p -> FIO (MResult p)
testIODep d = memoizeMVar $ case d of
IORead _ _ t -> t
2022-12-30 14:58:23 -05:00
IOConst c -> return $ Right $ PostPass c []
2022-12-26 10:44:03 -05:00
-- 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
2022-12-30 14:58:23 -05:00
IOAlways a f ->
Right
. uncurry PostPass
-- TODO this is wetter than Taco Bell shit
. bimap f (fmap stripMsg)
<$> evalAlwaysMsg a
IOSometimes x f ->
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
<$> evalSometimesMsg x
2022-07-07 01:05:17 -04:00
stripMsg :: FMsg -> Msg
stripMsg (FMsg _ _ m) = m
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- | Standalone dependency testing
2022-07-07 01:05:17 -04:00
type Result_ = Either [Msg] [Msg]
2022-12-26 10:44:03 -05:00
type MResult_ = Memoized Result_
testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
testTree_ test = go
where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
2022-12-30 14:58:23 -05:00
go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a
go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go
2022-12-26 10:44:03 -05:00
testIODep_ :: IODependency_ -> FIO MResult_
testIODep_ d = memoizeMVar $ testIODepNoCache_ d
2022-12-26 10:44:03 -05:00
testIODepNoCache_ :: IODependency_ -> FIO Result_
2022-12-27 19:39:16 -05:00
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
2022-12-30 14:58:23 -05:00
testIODepNoCache_ (IOSometimes_ x) =
bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-31 19:04:37 -05:00
-- System Dependency Testing
2022-06-28 21:24:21 -04:00
2022-12-31 19:04:37 -05:00
testSysDependency
:: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env)
=> SystemDependency
-> m (Maybe Msg)
2022-12-30 14:58:23 -05:00
testSysDependency (Executable sys bin) =
io $
maybe (Just msg) (const Nothing)
<$> findExecutable bin
where
2022-12-26 17:56:55 -05:00
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
e = if sys then "system" else "local"
2022-12-27 19:39:16 -05:00
testSysDependency (Systemd t n) = shellTest "systemctl" args msg
where
2022-12-26 17:56:55 -05:00
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
2022-12-27 19:39:16 -05:00
args = ["--user" | t == UserUnit] ++ ["status", n]
2022-12-30 14:58:23 -05:00
testSysDependency (Process n) =
shellTest "pidof" [n] $
T.unwords ["Process", singleQuote n, "not found"]
2022-12-27 19:39:16 -05:00
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
where
2022-12-30 14:58:23 -05:00
testPerm False _ _ = Nothing
testPerm True f res = Just $ f res
2022-12-26 17:56:55 -05:00
mkErr = Just . Msg LevelError
2022-12-30 14:58:23 -05:00
permMsg NotFoundError = mkErr "file not found"
permMsg PermError = mkErr "could not get permissions"
permMsg (PermResult res) =
case (testPerm r readable res, testPerm w writable res) of
2022-07-07 01:05:17 -04:00
(Just False, Just False) -> mkErr "file not readable or writable"
2022-12-30 14:58:23 -05:00
(Just False, _) -> mkErr "file not readable"
(_, Just False) -> mkErr "file not writable"
_ -> Nothing
2022-12-31 19:04:37 -05:00
shellTest
:: (MonadReader env m, HasProcessContext env, HasLogFunc env, MonadUnliftIO m)
=> FilePath
-> [T.Text]
-> T.Text
-> m (Maybe Msg)
2022-12-27 19:39:16 -05:00
shellTest cmd args msg = do
2022-12-28 00:04:33 -05:00
rc <- proc cmd (T.unpack <$> args) (runProcess . setStdout nullStream)
2022-07-02 17:09:21 -04:00
return $ case rc of
ExitSuccess -> Nothing
2022-12-30 14:58:23 -05:00
_ -> Just $ Msg LevelError msg
2022-07-02 17:09:21 -04:00
unitType :: UnitType -> T.Text
2022-06-28 21:24:21 -04:00
unitType SystemUnit = "system"
2022-12-30 14:58:23 -05:00
unitType UserUnit = "user"
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Font testers
--
-- Make a special case for these since we end up testing the font alot, and it
-- would be nice if I can cache them.
fontAlways :: T.Text -> T.Text -> [Fulfillment] -> Always FontBuilder
fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
where
root = IORoot id $ fontTree fam ful
2022-12-30 14:58:23 -05:00
fontSometimes :: T.Text -> T.Text -> [Fulfillment] -> Sometimes FontBuilder
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
where
root = IORoot id $ fontTree fam ful
fontFeatureName :: T.Text -> T.Text
fontFeatureName n = T.unwords ["Font family for", singleQuote n]
fontTreeAlt :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont
fontTree :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
fontTree n = Only . fontDependency n
fontTree_ :: T.Text -> [Fulfillment] -> IOTree_
fontTree_ n = Only_ . fontDependency_ n
fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_
2022-12-27 19:39:16 -05:00
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont fam
fontTestName :: T.Text -> T.Text
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
2022-12-27 19:39:16 -05:00
-- testFont :: T.Text -> FIO (Result FontBuilder)
-- testFont = liftIO . testFont'
2022-12-31 19:04:37 -05:00
testFont
:: (MonadUnliftIO m, MonadReader env m, HasProcessContext env, HasLogFunc env)
=> T.Text
-> m (Result FontBuilder)
2022-12-30 14:58:23 -05:00
testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
where
msg = T.unwords ["font family", qFam, "not found"]
2022-12-27 19:39:16 -05:00
args = [qFam]
qFam = singleQuote fam
2022-07-07 01:05:17 -04:00
pass = Right $ PostPass (buildFont $ Just fam) []
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Network Testers
--
-- ASSUME that the system uses systemd in which case ethernet interfaces always
-- start with "en" and wireless interfaces always start with "wl"
readEthernet :: IODependency T.Text
readEthernet = readInterface "get ethernet interface" isEthernet
readWireless :: IODependency T.Text
readWireless = readInterface "get wireless interface" isWireless
isWireless :: T.Text -> Bool
isWireless = T.isPrefixOf "wl"
isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en"
2022-12-31 19:04:37 -05:00
listInterfaces :: MonadUnliftIO m => m [T.Text]
2022-12-30 14:58:23 -05:00
listInterfaces =
fromRight []
2022-12-31 19:04:37 -05:00
<$> tryIO (fmap T.pack <$> listDirectory sysfsNet)
sysfsNet :: FilePath
sysfsNet = "/sys/class/net"
-- ASSUME there are no (non-base) packages required to make these interfaces
-- work (all at the kernel level)
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
readInterface n f = IORead n [] go
where
go = io $ do
ns <- filter f <$> listInterfaces
case ns of
2022-12-26 17:56:55 -05:00
[] -> return $ Left [Msg LevelError "no interfaces found"]
2022-12-30 14:58:23 -05:00
(x : xs) -> do
return $
Right $
PostPass x $
fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
2022-07-08 00:21:05 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Misc testers
2022-07-08 00:21:05 -04:00
2022-12-31 19:04:37 -05:00
socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
2022-12-30 14:58:23 -05:00
socketExists n ful =
2022-12-31 19:04:37 -05:00
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
2022-07-08 00:21:05 -04:00
2022-12-31 19:04:37 -05:00
socketExists' :: MonadUnliftIO m => m FilePath -> m (Maybe Msg)
2022-07-08 00:21:05 -04:00
socketExists' getPath = do
p <- getPath
2022-12-31 19:04:37 -05:00
r <- tryIO $ liftIO $ getFileStatus p
return $ case r of
2022-12-30 14:58:23 -05:00
Left e -> toErr $ T.pack $ ioe_description e
2022-12-31 19:04:37 -05:00
Right s | isSocket s -> Nothing
_ -> toErr $ T.append (T.pack p) " is not a socket"
2022-07-08 00:21:05 -04:00
where
2022-12-26 17:56:55 -05:00
toErr = Just . Msg LevelError
2022-07-08 00:21:05 -04:00
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DBus Dependency Testing
2022-06-28 21:24:21 -04:00
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
2022-12-26 10:44:03 -05:00
testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
2022-12-26 10:44:03 -05:00
testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDepNoCache_ cl (Bus _ bus) = io $ do
2022-07-09 17:44:14 -04:00
ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of
2022-12-30 14:58:23 -05:00
Left e -> Left [Msg LevelError e]
Right b ->
let ns = bodyGetNames b
in if bus' `elem` ns
then Right []
else
Left
[ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
]
2021-11-07 20:16:53 -05:00
where
bus' = T.pack $ formatBusName bus
queryBus = busName_ "org.freedesktop.DBus"
queryIface = interfaceName_ "org.freedesktop.DBus"
queryPath = objectPath_ "/"
queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
2022-12-30 14:58:23 -05:00
bodyGetNames _ = []
2022-12-26 10:44:03 -05:00
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
2022-07-09 17:44:14 -04:00
ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of
2022-12-30 14:58:23 -05:00
Left e -> Left [Msg LevelError e]
Right body -> procBody body
where
2022-12-30 14:58:23 -05:00
procBody body =
let res =
findMem
=<< I.parseXML objpath
=<< fromVariant
=<< listToMaybe body
in case res of
Just True -> Right []
_ -> Left [Msg LevelError $ fmtMsg' mem]
findMem =
fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface)
. I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
matchMem (Property_ n) = elemMember n (T.pack . I.propertyName) I.interfaceProperties
elemMember n fname fmember = elem n . fmap fname . fmember
2022-12-30 14:58:23 -05:00
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
2022-12-30 14:58:23 -05:00
fmtMsg' m =
T.unwords
[ "could not find"
, fmtMem m
, "on interface"
, singleQuote $ T.pack $ formatInterfaceName iface
, "on bus"
, T.pack $ formatBusName busname
]
2022-12-26 10:44:03 -05:00
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- IO Lifting functions
2022-06-28 21:24:21 -04:00
2022-12-31 16:23:17 -05:00
-- ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
-- ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs
2022-06-28 21:24:21 -04:00
2022-12-31 16:23:17 -05:00
-- ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
-- ioAlways (Always n x) = Always n $ ioAlways' x
2022-06-28 23:27:55 -04:00
2022-12-31 16:23:17 -05:00
-- ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
-- ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar
-- ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a
2022-06-28 21:24:21 -04:00
2022-12-31 16:23:17 -05:00
-- ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a)
-- ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a
-- ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s
2022-12-31 16:23:17 -05:00
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
2022-06-28 21:24:21 -04:00
2022-12-31 16:23:17 -05:00
-- 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
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Feature constructors
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
2022-12-30 14:58:23 -05:00
sometimes1_ x fn n t =
Sometimes
fn
x
[Subfeature {sfData = t, sfName = n}]
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
2022-12-30 14:58:23 -05:00
always1_ fn n t x =
Always fn $
Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x)
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
sometimes1 = sometimes1_ (const True)
always1 :: T.Text -> T.Text -> Root a -> a -> Always a
always1 = always1_
sometimesIO_ :: T.Text -> T.Text -> IOTree_ -> a -> Sometimes a
2022-07-02 17:09:21 -04:00
sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
2022-07-02 17:09:21 -04:00
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
2022-12-30 14:58:23 -05:00
sometimesExe
:: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> Sometimes (m ())
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
2022-06-28 21:24:21 -04:00
2022-12-30 14:58:23 -05:00
sometimesExeArgs
:: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> [T.Text]
-> Sometimes (m ())
sometimesExeArgs fn n ful sys path args =
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
2022-06-28 21:24:21 -04:00
2022-12-30 14:58:23 -05:00
sometimesDBus
:: SafeClient c
=> Maybe c
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (c -> a)
-> Sometimes a
2022-06-28 23:27:55 -04:00
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
2022-12-30 14:58:23 -05:00
sometimesEndpoint
:: (SafeClient c, MonadIO m)
=> T.Text
-> T.Text
-> [Fulfillment]
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe c
-> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd
2022-06-28 21:24:21 -04:00
where
deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
2022-07-09 17:44:14 -04:00
cmd c = io $ void $ callMethod c busname path iface mem
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Dependency Tree Constructors
listToAnds :: d -> [d] -> Tree_ d
listToAnds i = foldr (And_ . Only_) (Only_ i)
toAnd_ :: d -> d -> Tree_ d
toAnd_ a b = And_ (Only_ a) (Only_ b)
toFallback :: IODependency p -> p -> Tree IODependency d_ p
toFallback a = Or (Only a) . Only . IOConst
voidResult :: Result p -> Result_
2022-12-30 14:58:23 -05:00
voidResult (Left es) = Left es
voidResult (Right (PostPass _ ws)) = Right ws
2022-07-07 01:05:17 -04:00
voidRead :: Result p -> Maybe Msg
2022-12-30 14:58:23 -05:00
voidRead (Left []) = Just $ Msg LevelError "unspecified error"
voidRead (Left (e : _)) = Just e
voidRead (Right _) = Nothing
2022-07-07 01:05:17 -04:00
readResult_ :: Maybe Msg -> Result_
readResult_ (Just w) = Left [w]
2022-12-30 14:58:23 -05:00
readResult_ _ = Right []
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- IO Dependency Constructors
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
exe b ful = IOSystem_ ful . Executable b
sysExe :: [Fulfillment] -> FilePath -> IODependency_
sysExe = exe True
localExe :: [Fulfillment] -> FilePath -> IODependency_
localExe = exe False
path' :: Bool -> Bool -> FilePath -> [Fulfillment] -> IODependency_
path' r w n ful = IOSystem_ ful $ AccessiblePath n r w
pathR :: FilePath -> [Fulfillment] -> IODependency_
pathR = path' True False
pathW :: FilePath -> [Fulfillment] -> IODependency_
pathW = path' False True
pathRW :: FilePath -> [Fulfillment] -> IODependency_
pathRW = path' True True
sysd :: UnitType -> [Fulfillment] -> T.Text -> IODependency_
sysd u ful = IOSystem_ ful . Systemd u
sysdUser :: [Fulfillment] -> T.Text -> IODependency_
sysdUser = sysd UserUnit
sysdSystem :: [Fulfillment] -> T.Text -> IODependency_
sysdSystem = sysd SystemUnit
process :: [Fulfillment] -> T.Text -> IODependency_
process ful = IOSystem_ ful . Process
2022-06-28 21:24:21 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Dependency data for JSON
2022-12-25 18:07:03 -05:00
type DependencyData = [Fulfillment]
2022-06-28 21:24:21 -04:00
2022-12-25 18:07:03 -05:00
dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData
2022-12-30 14:58:23 -05:00
dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r
2022-06-28 21:24:21 -04:00
2022-12-25 18:07:03 -05:00
dataRoot :: Root a -> DependencyData
2022-12-30 14:58:23 -05:00
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
2022-06-28 21:24:21 -04:00
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
2022-12-30 14:58:23 -05:00
dataTree
:: forall d d_ p
. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData)
-> Tree d d_ p
-> DependencyData
2022-06-28 21:24:21 -04:00
dataTree f f_ = go
where
2022-12-25 18:07:03 -05:00
go :: forall q. Tree d d_ q -> DependencyData
go (And12 _ a b) = go a ++ go b
2022-12-30 14:58:23 -05:00
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
2022-12-25 18:07:03 -05:00
dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData
2022-06-28 21:24:21 -04:00
dataTree_ f_ = go
where
2022-12-25 18:07:03 -05:00
go (And_ a b) = go a ++ go b
2022-12-30 14:58:23 -05:00
go (Or_ a _) = go a
go (Only_ d) = f_ d
2022-06-28 21:24:21 -04:00
dataIODependency :: IODependency p -> DependencyData
2022-12-25 18:07:03 -05:00
dataIODependency d = case d of
2022-12-30 14:58:23 -05:00
(IORead _ f _) -> f
2022-12-25 18:07:03 -05:00
(IOSometimes x _) -> dumpSometimes x
2022-12-30 14:58:23 -05:00
(IOAlways x _) -> dumpAlways x
_ -> []
2022-06-28 21:24:21 -04:00
dataIODependency_ :: IODependency_ -> DependencyData
dataIODependency_ d = case d of
2022-12-30 14:58:23 -05:00
(IOSystem_ f _) -> f
(IOTest_ _ f _) -> f
2022-12-25 18:07:03 -05:00
(IOSometimes_ x) -> dumpSometimes x
2022-06-28 21:24:21 -04:00
2022-07-09 17:08:10 -04:00
dataDBusDependency :: DBusDependency_ c -> DependencyData
2022-12-25 18:07:03 -05:00
dataDBusDependency d = case d of
2022-12-30 14:58:23 -05:00
(Bus f _) -> f
(Endpoint f _ _ _ _) -> f
(DBusIO x) -> dataIODependency_ x
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- formatting
bracket :: T.Text -> T.Text
bracket s = T.concat ["[", s, "]"]