ENH use rio for memoization
This commit is contained in:
parent
48722f79a4
commit
1f39c0dc67
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue