ENH use rio for memoization
This commit is contained in:
parent
48722f79a4
commit
1f39c0dc67
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ extra-source-files:
|
|||
- sound/*
|
||||
|
||||
dependencies:
|
||||
- rio >= 0.1.21.0
|
||||
- X11 >= 1.9.1
|
||||
- base
|
||||
- bytestring >= 0.10.8.2
|
||||
|
|
|
|||
Loading…
Reference in New Issue