ENH use rio for memoization

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

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
+-- -- 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
 
-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
+-- 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 = 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_ :: IODependency_ -> FIO (Memoized Result_)
-testIODependency_ = memoizeIO_ testIODependency'_
+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

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