ENH memoize non-standalone IODeps
This commit is contained in:
parent
1f39c0dc67
commit
5ed8c769fa
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue