From 1f39c0dc67bfa3b989f937820612af35d4f571f5 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 26 Dec 2022 09:44:49 -0500 Subject: [PATCH] ENH use rio for memoization --- bin/xmonad.hs | 5 +- lib/Data/Internal/Dependency.hs | 94 +++++++++++++++++---------------- package.yaml | 1 + 3 files changed, 52 insertions(+), 48 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index f1f837e..f4fa328 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -7,7 +7,6 @@ module Main (main) where import Control.Concurrent -import Control.Concurrent.Lifted import Control.Monad import Data.Internal.DBus @@ -20,6 +19,8 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras +import RIO (async) + import System.Directory import System.Environment import System.IO @@ -169,7 +170,7 @@ evalConf db@DBusState { dbSysClient = cl } = do return (h, ThreadState (p:ps) [h]) startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db - startPowerMon fs = void $ fork $ void $ executeSometimes $ fsPowerMon fs + startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs startDynWorkspaces fs = do dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) io $ forkIO_ $ runWorkspaceMon dws diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 3f679f6..a55e2b6 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -109,28 +109,30 @@ module Data.Internal.Dependency import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.Reader -import Control.Monad.State +-- 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 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.Generics (Generic) import GHC.IO.Exception (ioe_description) import DBus hiding (typeOf) import qualified DBus.Introspection as I +import RIO hiding (LogLevel, bracket, fromString) + import System.Directory import System.Environment -import System.Exit +-- import System.Exit import System.FilePath import System.IO.Error import System.Posix.Files @@ -152,7 +154,7 @@ import XMonad.Internal.Theme withCache :: FIO a -> IO a withCache x = do p <- getParams - evalStateT (runReaderT x p) emptyCache + runRIO p x -- | Execute an Always immediately 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 the results will always be the same. --- TODO cache DBus calls -emptyCache :: Cache -emptyCache = Cache H.empty H.empty +-- -- 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]) +-- 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]) +-- 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 -type FIO a = ReaderT XParams (StateT Cache IO) a +type FIO a = RIO XParams a data XParams = XParams { xpLogLevel :: LogLevel @@ -524,12 +526,12 @@ 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) - } +-- 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 @@ -649,7 +651,7 @@ testRoot r = do 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)) testTree test_ test = go where @@ -692,16 +694,16 @@ stripMsg (FMsg _ _ m) = m 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 where go (And_ a b) = either (return . Left) (`test2nd` b) =<< 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 -testIODependency_ :: IODependency_ -> FIO Result_ -testIODependency_ = memoizeIO_ testIODependency'_ +testIODependency_ :: IODependency_ -> FIO (Memoized Result_) +testIODependency_ d = memoizeMVar $ testIODependency'_ d testIODependency'_ :: IODependency_ -> FIO Result_ testIODependency'_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s @@ -787,7 +789,7 @@ fontTestName :: String -> String fontTestName fam = unwords ["test if font", singleQuote fam, "exists"] testFont :: String -> FIO (Result FontBuilder) -testFont = memoizeFont testFont' +testFont = liftIO . testFont' testFont' :: String -> IO (Result FontBuilder) testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg @@ -862,9 +864,9 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectMethod :: MemberName 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_ = testDBusDependency'_ +testDBusDependency_ c d = memoizeMVar $ testDBusDependency'_ c d testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDependency'_ cl (Bus _ bus) = io $ do @@ -915,7 +917,7 @@ testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do , formatBusName busname ] -testDBusDependency'_ _ (DBusIO i) = testIODependency_ i +testDBusDependency'_ _ (DBusIO i) = runMemoized =<< testIODependency_ i -------------------------------------------------------------------------------- -- | IO Lifting functions diff --git a/package.yaml b/package.yaml index a94f5c6..6e1ca78 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,7 @@ extra-source-files: - sound/* dependencies: + - rio >= 0.1.21.0 - X11 >= 1.9.1 - base - bytestring >= 0.10.8.2