ENH use rio for memoization

This commit is contained in:
Nathan Dwarshuis 2022-12-26 09:44:49 -05:00
parent 48722f79a4
commit 1f39c0dc67
3 changed files with 52 additions and 48 deletions

View File

@ -7,7 +7,6 @@
module Main (main) where module Main (main) where
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Lifted
import Control.Monad import Control.Monad
import Data.Internal.DBus import Data.Internal.DBus
@ -20,6 +19,8 @@ import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import RIO (async)
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.IO import System.IO
@ -169,7 +170,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
return (h, ThreadState (p:ps) [h]) return (h, ThreadState (p:ps) [h])
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
$ dbSysClient db $ dbSysClient db
startPowerMon fs = void $ fork $ void $ executeSometimes $ fsPowerMon fs startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
io $ forkIO_ $ runWorkspaceMon dws io $ forkIO_ $ runWorkspaceMon dws

View File

@ -109,28 +109,30 @@ 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 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 qualified Data.HashMap.Strict as H
import Data.Hashable 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.Generics (Generic)
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf) import DBus hiding (typeOf)
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import RIO hiding (LogLevel, bracket, fromString)
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.Exit -- 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
@ -152,7 +154,7 @@ import XMonad.Internal.Theme
withCache :: FIO a -> IO a withCache :: FIO a -> IO a
withCache x = do withCache x = do
p <- getParams p <- getParams
evalStateT (runReaderT x p) emptyCache runRIO p x
-- | Execute an Always immediately -- | Execute an Always immediately
executeAlways :: Always (IO a) -> FIO a executeAlways :: Always (IO a) -> FIO a
@ -427,38 +429,38 @@ data PostFail = PostFail [Msg] | PostMissing Msg
-- that each repeated test without caching would be run in such close succession -- that each repeated test without caching would be run in such close succession
-- that the results will always be the same. -- that the results will always be the same.
-- TODO cache DBus calls -- -- TODO cache DBus calls
emptyCache :: Cache -- emptyCache :: Cache
emptyCache = Cache H.empty H.empty -- emptyCache = Cache H.empty H.empty
memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_ -- memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
memoizeIO_ f d = do -- memoizeIO_ f d = do
m <- gets cIO_ -- m <- gets cIO_
case H.lookup d m of -- case H.lookup d m of
(Just r) -> return $ info "retrieving from to cache" r -- (Just r) -> return $ info "retrieving from to cache" r
Nothing -> do -- Nothing -> do
r <- info "adding to cache" <$> f d -- r <- info "adding to cache" <$> f d
modify (\s -> s { cIO_ = H.insert d r (cIO_ s) }) -- modify (\s -> s { cIO_ = H.insert d r (cIO_ s) })
return r -- return r
where -- where
info m = fmap (++ [Msg Info m]) -- info m = fmap (++ [Msg Info m])
memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder) -- memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder)
memoizeFont f d = do -- memoizeFont f d = do
m <- gets cFont -- m <- gets cFont
case H.lookup d m of -- case H.lookup d m of
(Just r) -> return $ info "retrieving from cache" r -- (Just r) -> return $ info "retrieving from cache" r
Nothing -> do -- Nothing -> do
r <- io $ info "adding to cache" <$> f d -- r <- io $ info "adding to cache" <$> f d
modify (\s -> s { cFont = H.insert d r (cFont s) }) -- modify (\s -> s { cFont = H.insert d r (cFont s) })
return r -- return r
where -- where
info m = fmap (`addMsgs` [Msg Info m]) -- info m = fmap (`addMsgs` [Msg Info m])
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Configuration -- | Configuration
type FIO a = ReaderT XParams (StateT Cache IO) a type FIO a = RIO XParams a
data XParams = XParams data XParams = XParams
{ xpLogLevel :: LogLevel { xpLogLevel :: LogLevel
@ -524,12 +526,12 @@ defXPFeatures = XPFeatures
type XPQuery = XPFeatures -> Bool type XPQuery = XPFeatures -> Bool
data Cache = Cache -- data Cache = Cache
{ --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p) -- { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
cIO_ :: H.HashMap IODependency_ Result_ -- cIO_ :: H.HashMap IODependency_ Result_
-- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_ -- -- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_
, cFont :: H.HashMap String (Result FontBuilder) -- , cFont :: H.HashMap String (Result FontBuilder)
} -- }
getParams :: IO XParams getParams :: IO XParams
getParams = do getParams = do
@ -649,7 +651,7 @@ testRoot r = do
type Result p = Either [Msg] (PostPass p) type Result p = Either [Msg] (PostPass p)
testTree :: forall d d_ p. (d_ -> FIO Result_) -> (forall q. d q -> FIO (Result q)) 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)) -> Tree d d_ p -> FIO (Either [Msg] (PostPass p))
testTree test_ test = go testTree test_ test = go
where where
@ -692,16 +694,16 @@ stripMsg (FMsg _ _ m) = m
type Result_ = Either [Msg] [Msg] type Result_ = Either [Msg] [Msg]
testTree_ :: (d -> FIO Result_) -> Tree_ d -> FIO Result_ testTree_ :: (d -> FIO (Memoized Result_)) -> 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
go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a
go (Only_ a) = test a go (Only_ a) = runMemoized =<< test a
test2nd ws = fmap ((Right . (ws ++)) =<<) . go test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> FIO Result_ testIODependency_ :: IODependency_ -> FIO (Memoized Result_)
testIODependency_ = memoizeIO_ testIODependency'_ testIODependency_ d = memoizeMVar $ testIODependency'_ d
testIODependency'_ :: IODependency_ -> FIO Result_ testIODependency'_ :: IODependency_ -> FIO Result_
testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
@ -787,7 +789,7 @@ fontTestName :: String -> String
fontTestName fam = unwords ["test if font", singleQuote fam, "exists"] fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
testFont :: String -> FIO (Result FontBuilder) testFont :: String -> FIO (Result FontBuilder)
testFont = memoizeFont testFont' testFont = liftIO . testFont'
testFont' :: String -> IO (Result FontBuilder) testFont' :: String -> IO (Result FontBuilder)
testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
@ -862,9 +864,9 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO (Memoized Result_)
-- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl) -- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
testDBusDependency_ = testDBusDependency'_ testDBusDependency_ c d = memoizeMVar $ testDBusDependency'_ c d
testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
testDBusDependency'_ cl (Bus _ bus) = io $ do testDBusDependency'_ cl (Bus _ bus) = io $ do
@ -915,7 +917,7 @@ testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
, formatBusName busname , formatBusName busname
] ]
testDBusDependency'_ _ (DBusIO i) = testIODependency_ i testDBusDependency'_ _ (DBusIO i) = runMemoized =<< testIODependency_ i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Lifting functions -- | IO Lifting functions

View File

@ -14,6 +14,7 @@ extra-source-files:
- sound/* - sound/*
dependencies: dependencies:
- rio >= 0.1.21.0
- X11 >= 1.9.1 - X11 >= 1.9.1
- base - base
- bytestring >= 0.10.8.2 - bytestring >= 0.10.8.2