From 5ed8c769fa2de97196836b4a32e552f182589edb Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 26 Dec 2022 10:44:03 -0500 Subject: [PATCH] ENH memoize non-standalone IODeps --- lib/Data/Internal/Dependency.hs | 230 ++++++-------------------------- 1 file changed, 42 insertions(+), 188 deletions(-) diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index a55e2b6..40b062a 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -109,20 +109,16 @@ module Data.Internal.Dependency import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.Reader --- import Control.Monad.State import Data.Aeson hiding (Error, Result) import Data.Aeson.Key import Data.Bifunctor import Data.Either --- import qualified Data.HashMap.Strict as H -import Data.Hashable import Data.Internal.DBus import Data.List import Data.Maybe import Data.Yaml --- import GHC.Generics (Generic) import GHC.IO.Exception (ioe_description) import DBus hiding (typeOf) @@ -132,7 +128,6 @@ import RIO hiding (LogLevel, bracket, fromString) import System.Directory import System.Environment --- import System.Exit import System.FilePath import System.IO.Error import System.Posix.Files @@ -300,7 +295,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c) -- | A dependency that only requires IO to evaluate (with payload) data IODependency p = - -- a cachable IO action that yields a payload + -- an IO action that yields a payload IORead String [Fulfillment] (FIO (Result p)) -- always yields a payload | IOConst p @@ -313,36 +308,13 @@ data IODependency p = data DBusDependency_ c = Bus [Fulfillment] BusName | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | DBusIO IODependency_ - deriving (Eq, Generic) - -instance Hashable (DBusDependency_ c) where - hashWithSalt s (Bus f b) = s `hashWithSalt` f - `hashWithSalt` formatBusName b - hashWithSalt s (Endpoint f b o i m) = s `hashWithSalt` f - `hashWithSalt` formatBusName b - `hashWithSalt` formatObjectPath o - `hashWithSalt` formatInterfaceName i - `hashWithSalt` m - hashWithSalt s (DBusIO i) = hashWithSalt s i + deriving (Generic) -- | A dependency that only requires IO to evaluate (no payload) data IODependency_ = IOSystem_ [Fulfillment] SystemDependency | IOTest_ String [Fulfillment] (IO (Maybe Msg)) | forall a. IOSometimes_ (Sometimes a) -instance Eq IODependency_ where - (==) (IOSystem_ f0 s0) (IOSystem_ f1 s1) = f0 == f1 && s0 == s1 - (==) (IOTest_ {}) (IOTest_ {}) = False - (==) (IOSometimes_ _) (IOSometimes_ _) = False - (==) _ _ = False - -instance Hashable IODependency_ where - hashWithSalt s (IOSystem_ f y) = s `hashWithSalt` f - `hashWithSalt` y - hashWithSalt s (IOTest_ n f _) = s `hashWithSalt` n - `hashWithSalt` f - hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n - -- | A system component to an IODependency -- This name is dumb, but most constructors should be obvious data SystemDependency = @@ -352,36 +324,21 @@ data SystemDependency = | Process String deriving (Eq, Show, Generic) -instance Hashable SystemDependency - -- | The type of a systemd service data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) -instance Hashable UnitType - -- | Wrapper type to describe and endpoint data DBusMember = Method_ MemberName | Signal_ MemberName | Property_ String deriving (Eq, Show, Generic) -instance Hashable DBusMember where - hashWithSalt s (Method_ m) = hashWithSalt s $ formatMemberName m - hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m - hashWithSalt s (Property_ p) = hashWithSalt s p - --- 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, Ord) -instance Hashable Fulfillment where - hashWithSalt s (Package a n) = s `hashWithSalt` a `hashWithSalt` n - data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) -instance Hashable ArchPkg - -------------------------------------------------------------------------------- -- | Tested dependency tree -- @@ -419,44 +376,6 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms' -- | An action that failed data PostFail = PostFail [Msg] | PostMissing Msg --------------------------------------------------------------------------------- --- | Evaluation cache --- --- Setting up trees like this usually entails having some repeated dependencies. --- Testing the same dependency multiple times is stupid, so cache the results. --- Note this is basically memorization, except that the results are IO-dependent --- and this may technically change with each invocation. The assumption here is --- that each repeated test without caching would be run in such close succession --- that the results will always be the same. - --- -- TODO cache DBus calls --- emptyCache :: Cache --- emptyCache = Cache H.empty H.empty - --- memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_ --- memoizeIO_ f d = do --- m <- gets cIO_ --- case H.lookup d m of --- (Just r) -> return $ info "retrieving from to cache" r --- Nothing -> do --- r <- info "adding to cache" <$> f d --- modify (\s -> s { cIO_ = H.insert d r (cIO_ s) }) --- return r --- where --- info m = fmap (++ [Msg Info m]) - --- memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder) --- memoizeFont f d = do --- m <- gets cFont --- case H.lookup d m of --- (Just r) -> return $ info "retrieving from cache" r --- Nothing -> do --- r <- io $ info "adding to cache" <$> f d --- modify (\s -> s { cFont = H.insert d r (cFont s) }) --- return r --- where --- info m = fmap (`addMsgs` [Msg Info m]) - -------------------------------------------------------------------------------- -- | Configuration @@ -526,13 +445,6 @@ defXPFeatures = XPFeatures type XPQuery = XPFeatures -> Bool --- data Cache = Cache --- { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p) --- cIO_ :: H.HashMap IODependency_ Result_ --- -- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_ --- , cFont :: H.HashMap String (Result FontBuilder) --- } - getParams :: IO XParams getParams = do p <- getParamFile @@ -634,15 +546,15 @@ testSubfeature sf@Subfeature{ sfData = t } = do testRoot :: Root a -> FIO (Either PostFail (PostPass a)) testRoot r = do case r of - (IORoot a t) -> go a testIODependency_ testIODependency t - (IORoot_ a t) -> go_ a testIODependency_ t - (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t - (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t + (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 + (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t _ -> return $ Left $ PostMissing $ Msg Error "client not available" where -- rank N polymorphism is apparently undecidable...gross - go a f_ (f :: forall q. d q -> FIO (Result q)) t = + go a f_ (f :: forall q. d q -> FIO (MResult q)) t = bimap PostFail (fmap a) <$> testTree f_ f t go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t @@ -651,11 +563,15 @@ testRoot r = do type Result p = Either [Msg] (PostPass p) -testTree :: forall d d_ p. (d_ -> FIO (Memoized Result_)) -> (forall q. d q -> FIO (Result q)) - -> Tree d d_ p -> FIO (Either [Msg] (PostPass p)) +type MResult p = Memoized (Result p) + +testTree :: forall d d_ p. (d_ -> FIO MResult_) + -> (forall q. d q -> FIO (MResult q)) + -> Tree d d_ p + -> FIO (Either [Msg] (PostPass p)) testTree test_ test = go where - go :: forall q. Tree d d_ q -> FIO (Either [Msg] (PostPass q)) + go :: forall q. Tree d d_ q -> FIO (Result q) go (And12 f a b) = do ra <- go a liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra @@ -668,23 +584,23 @@ testTree test_ test = go go (Or a b) = do ra <- go a either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra - go (Only a) = test a + go (Only a) = runMemoized =<< test a and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb liftRight = either (return . Left) -testIODependency :: IODependency p -> FIO (Result p) -testIODependency (IORead _ _ t) = t -testIODependency (IOConst c) = return $ Right $ PostPass c [] --- 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 -testIODependency (IOAlways a f) = Right . uncurry PostPass +testIODep :: IODependency p -> FIO (MResult p) +testIODep d = memoizeMVar $ case d of + IORead _ _ t -> t + IOConst c -> return $ Right $ PostPass c [] + -- 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 + IOAlways a f -> Right . uncurry PostPass -- TODO this is wetter than Taco Bell shit - . bimap f (fmap stripMsg) <$> evalAlwaysMsg a -testIODependency (IOSometimes x f) = - bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) - <$> evalSometimesMsg x + . bimap f (fmap stripMsg) <$> evalAlwaysMsg a + IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) + <$> evalSometimesMsg x stripMsg :: FMsg -> Msg stripMsg (FMsg _ _ m) = m @@ -694,7 +610,9 @@ stripMsg (FMsg _ _ m) = m type Result_ = Either [Msg] [Msg] -testTree_ :: (d -> FIO (Memoized Result_)) -> Tree_ d -> FIO Result_ +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 @@ -702,13 +620,13 @@ testTree_ test = go go (Only_ a) = runMemoized =<< test a test2nd ws = fmap ((Right . (ws ++)) =<<) . go -testIODependency_ :: IODependency_ -> FIO (Memoized Result_) -testIODependency_ d = memoizeMVar $ testIODependency'_ d +testIODep_ :: IODependency_ -> FIO MResult_ +testIODep_ d = memoizeMVar $ testIODepNoCache_ d -testIODependency'_ :: IODependency_ -> FIO Result_ -testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s -testIODependency'_ (IOTest_ _ _ t) = io $ readResult_ <$> t -testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) +testIODepNoCache_ :: IODependency_ -> FIO Result_ +testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s +testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t +testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) <$> evalSometimesMsg x -------------------------------------------------------------------------------- @@ -864,12 +782,11 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" -testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO (Memoized Result_) --- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl) -testDBusDependency_ c d = memoizeMVar $ testDBusDependency'_ c d +testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_ +testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d -testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ -testDBusDependency'_ cl (Bus _ bus) = io $ do +testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ +testDBusDepNoCache_ cl (Bus _ bus) = io $ do ret <- callMethod cl queryBus queryPath queryIface queryMem return $ case ret of Left e -> Left [Msg Error e] @@ -887,7 +804,7 @@ testDBusDependency'_ cl (Bus _ bus) = io $ do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do +testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do ret <- callMethod cl busname objpath introspectInterface introspectMethod return $ case ret of Left e -> Left [Msg Error e] @@ -917,7 +834,7 @@ testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do , formatBusName busname ] -testDBusDependency'_ _ (DBusIO i) = runMemoized =<< testIODependency_ i +testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i -------------------------------------------------------------------------------- -- | IO Lifting functions @@ -1051,69 +968,6 @@ sysdSystem = sysd SystemUnit process :: [Fulfillment] -> String -> IODependency_ process ful = IOSystem_ ful . Process --------------------------------------------------------------------------------- --- | Printing - --- 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) - --- 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 (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