ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH memoize non-standalone IODeps

This commit is contained in:
Nathan Dwarshuis 2022-12-26 10:44:03 -05:00
parent 1f39c0dc67
commit 5ed8c769fa
1 changed files with 42 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

222
lib/Data/Internal/Dependency.hs
View File

@ -109,20 +109,16 @@ module Data.Internal.Dependency
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Reader import Control.Monad.Reader
-- import Control.Monad.State
import Data.Aeson hiding (Error, Result) import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Bifunctor import Data.Bifunctor
import Data.Either import Data.Either
-- import qualified Data.HashMap.Strict as H
import Data.Hashable
import Data.Internal.DBus import Data.Internal.DBus
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Yaml import Data.Yaml
-- import GHC.Generics (Generic)
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf) import DBus hiding (typeOf)
@ -132,7 +128,6 @@ import RIO hiding (LogLevel, bracket, fromString)
import System.Directory import System.Directory
import System.Environment import System.Environment
-- import System.Exit
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
import System.Posix.Files import System.Posix.Files
@ -300,7 +295,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | A dependency that only requires IO to evaluate (with payload) -- | A dependency that only requires IO to evaluate (with payload)
data IODependency p = data IODependency p =
-- a cachable IO action that yields a payload -- an IO action that yields a payload
IORead String [Fulfillment] (FIO (Result p)) IORead String [Fulfillment] (FIO (Result p))
-- always yields a payload -- always yields a payload
| IOConst p | IOConst p
@ -313,36 +308,13 @@ data IODependency p =
data DBusDependency_ c = Bus [Fulfillment] BusName data DBusDependency_ c = Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | DBusIO IODependency_
deriving (Eq, Generic) deriving (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
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
| IOTest_ String [Fulfillment] (IO (Maybe Msg)) | IOTest_ String [Fulfillment] (IO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | 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 -- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious -- This name is dumb, but most constructors should be obvious
data SystemDependency = data SystemDependency =
@ -352,36 +324,21 @@ data SystemDependency =
| Process String | Process String
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
instance Hashable SystemDependency
-- | The type of a systemd service -- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
instance Hashable UnitType
-- | Wrapper type to describe and endpoint -- | Wrapper type to describe and endpoint
data DBusMember = Method_ MemberName data DBusMember = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ String | Property_ String
deriving (Eq, Show, Generic) 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 -- | 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, Ord) 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) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
instance Hashable ArchPkg
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Tested dependency tree -- | Tested dependency tree
-- --
@ -419,44 +376,6 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
-- | An action that failed -- | An action that failed
data PostFail = PostFail [Msg] | PostMissing Msg 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 -- | Configuration
@ -526,13 +445,6 @@ defXPFeatures = XPFeatures
type XPQuery = XPFeatures -> Bool 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 :: IO XParams
getParams = do getParams = do
p <- getParamFile p <- getParamFile
@ -634,15 +546,15 @@ testSubfeature sf@Subfeature{ sfData = t } = do
testRoot :: Root a -> FIO (Either PostFail (PostPass a)) testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do testRoot r = do
case r of case r of
(IORoot a t) -> go a testIODependency_ testIODependency t (IORoot a t) -> go a testIODep_ testIODep t
(IORoot_ a t) -> go_ a testIODependency_ t (IORoot_ a t) -> go_ a testIODep_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDependency_ cl) testIODependency t (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
_ -> return $ Left $ PostMissing _ -> return $ Left $ PostMissing
$ Msg Error "client not available" $ Msg Error "client not available"
where where
-- rank N polymorphism is apparently undecidable...gross -- 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 bimap PostFail (fmap a) <$> testTree f_ f t
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ 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) type Result p = Either [Msg] (PostPass p)
testTree :: forall d d_ p. (d_ -> FIO (Memoized Result_)) -> (forall q. d q -> FIO (Result q)) type MResult p = Memoized (Result p)
-> Tree d d_ p -> FIO (Either [Msg] (PostPass 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 testTree test_ test = go
where 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 go (And12 f a b) = do
ra <- go a ra <- go a
liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@ -668,22 +584,22 @@ testTree test_ test = go
go (Or a b) = do go (Or a b) = do
ra <- go a ra <- go a
either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra 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 and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
liftRight = either (return . Left) liftRight = either (return . Left)
testIODependency :: IODependency p -> FIO (Result p) testIODep :: IODependency p -> FIO (MResult p)
testIODependency (IORead _ _ t) = t testIODep d = memoizeMVar $ case d of
testIODependency (IOConst c) = return $ Right $ PostPass c [] IORead _ _ t -> t
IOConst c -> return $ Right $ PostPass c []
-- TODO this is a bit odd because this is a dependency that will always -- 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 -- succeed, which kinda makes this pointless. The only reason I would want
-- is if I want to have a built-in logic to "choose" a payload to use in -- this is if I want to have a built-in logic to "choose" a payload to use in
-- building a higher-level feature -- building a higher-level feature
testIODependency (IOAlways a f) = Right . uncurry PostPass IOAlways a f -> Right . uncurry PostPass
-- TODO this is wetter than Taco Bell shit -- TODO this is wetter than Taco Bell shit
. bimap f (fmap stripMsg) <$> evalAlwaysMsg a . bimap f (fmap stripMsg) <$> evalAlwaysMsg a
testIODependency (IOSometimes x f) = IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
<$> evalSometimesMsg x <$> evalSometimesMsg x
stripMsg :: FMsg -> Msg stripMsg :: FMsg -> Msg
@ -694,7 +610,9 @@ stripMsg (FMsg _ _ m) = m
type Result_ = Either [Msg] [Msg] 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 testTree_ test = go
where where
go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@ -702,13 +620,13 @@ testTree_ test = go
go (Only_ a) = runMemoized =<< test a go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> FIO (Memoized Result_) testIODep_ :: IODependency_ -> FIO MResult_
testIODependency_ d = memoizeMVar $ testIODependency'_ d testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODependency'_ :: IODependency_ -> FIO Result_ testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
testIODependency'_ (IOTest_ _ _ t) = io $ readResult_ <$> t testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t
testIODependency'_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x <$> evalSometimesMsg x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -864,12 +782,11 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO (Memoized Result_) testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
-- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl) testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
testDBusDependency_ c d = memoizeMVar $ testDBusDependency'_ c d
testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDependency'_ cl (Bus _ bus) = io $ do testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [Msg Error e] Left e -> Left [Msg Error e]
@ -887,7 +804,7 @@ testDBusDependency'_ cl (Bus _ bus) = io $ do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] 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 ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [Msg Error e] Left e -> Left [Msg Error e]
@ -917,7 +834,7 @@ testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
, formatBusName busname , formatBusName busname
] ]
testDBusDependency'_ _ (DBusIO i) = runMemoized =<< testIODependency_ i testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Lifting functions -- | IO Lifting functions
@ -1051,69 +968,6 @@ sysdSystem = sysd SystemUnit
process :: [Fulfillment] -> String -> IODependency_ process :: [Fulfillment] -> String -> IODependency_
process ful = IOSystem_ ful . Process 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 -- | Dependency data for JSON