From c292c2b9a82d6e67289edd31c34242ceb0a75d13 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 6 Jul 2022 00:16:47 -0400 Subject: [PATCH] ENH use faster function for finding VMs --- bin/xmonad.hs | 21 ++++--- lib/XMonad/Internal/Dependency.hs | 93 ++++++++++++++++++++++--------- my-xmonad.cabal | 2 + 3 files changed, 80 insertions(+), 36 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 9647270..bb081a3 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -24,9 +24,7 @@ import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Extras import System.Environment -import System.Exit import System.IO -import System.IO.Error import System.Process import XMonad @@ -48,6 +46,7 @@ import XMonad.Internal.Command.Power import XMonad.Internal.Concurrent.ACPIEvent import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.DynamicWorkspaces +import XMonad.Internal.Concurrent.VirtualBox import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.IntelBacklight @@ -275,15 +274,15 @@ vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root , dwCmd = Just $ spawnCmd "vbox-start" [vm] } --- TODO this shell command is hilariously slow and kills my fast startup time -vmExists :: String -> IO (Maybe String) -vmExists vm = - go <$> tryIOError (readCreateProcessWithExitCode' pr "") - where - pr = proc' "VBoxManage" ["showvminfo", vm] - go (Right (ExitSuccess, _, _)) = Nothing - go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm - go (Left e) = Just $ show e +-- -- TODO this shell command is hilariously slow and kills my fast startup time +-- vmExists :: String -> IO (Maybe String) +-- vmExists vm = +-- go <$> tryIOError (readCreateProcessWithExitCode' pr "") +-- where +-- pr = proc' "VBoxManage" ["showvminfo", vm] +-- go (Right (ExitSuccess, _, _)) = Nothing +-- go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm +-- go (Left e) = Just $ show e xsaneDynamicWorkspace :: Sometimes DynWorkspace xsaneDynamicWorkspace = sometimesIO_ "scanner workspace" "xsane" tree dw diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 1d549c2..4303555 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -104,7 +104,7 @@ import Data.Maybe import GHC.Generics (Generic) -import DBus +import DBus hiding (typeOf) import DBus.Client import DBus.Internal import qualified DBus.Introspection as I @@ -287,17 +287,31 @@ data IODependency p = data DBusDependency_ = Bus BusName | Endpoint BusName ObjectPath InterfaceName DBusMember | DBusIO IODependency_ + deriving (Eq, Generic) + +instance Hashable DBusDependency_ where + hashWithSalt s (Bus b) = hashWithSalt s $ formatBusName b + hashWithSalt s (Endpoint b o i m) = s `hashWithSalt` formatBusName b + `hashWithSalt` formatObjectPath o + `hashWithSalt` formatInterfaceName i + `hashWithSalt` m + hashWithSalt s (DBusIO i) = hashWithSalt s i -- | A dependency that only requires IO to evaluate (no payload) data IODependency_ = IOSystem_ SystemDependency | IOTest_ String (IO (Maybe String)) | forall a. IOSometimes_ (Sometimes a) --- instance Eq IODependency_ where --- (==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1 --- (==) (IOTest_ _ _) (IOTest_ _ _) = False --- (==) (IOSometimes_ _) (IOSometimes_ _) = False --- (==) _ _ = False +instance Eq IODependency_ where + (==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1 + (==) (IOTest_ _ _) (IOTest_ _ _) = False + (==) (IOSometimes_ _) (IOSometimes_ _) = False + (==) _ _ = False + +instance Hashable IODependency_ where + hashWithSalt s (IOSystem_ y) = hashWithSalt s y + hashWithSalt s (IOTest_ n _) = hashWithSalt s n + hashWithSalt s (IOSometimes_ (Sometimes n _)) = hashWithSalt s n -- | A system component to an IODependency -- This name is dumb, but most constructors should be obvious @@ -318,7 +332,12 @@ instance Hashable UnitType data DBusMember = Method_ MemberName | Signal_ MemberName | Property_ String - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Hashable DBusMember where + hashWithSalt s (Method_ m) = hashWithSalt s $ formatMemberName m + hashWithSalt s (Signal_ m) = hashWithSalt s $ formatMemberName m + hashWithSalt s (Property_ p) = hashWithSalt s p -------------------------------------------------------------------------------- -- | Tested dependency tree @@ -363,21 +382,39 @@ data PostFail = PostFail [String] | PostMissing String type FIO a = StateT Cache IO a -newtype Cache = Cache - { cSys :: H.HashMap SystemDependency Result_ - -- , cIO :: forall p. H.HashMap (IODependency p) (Result p) - -- , cIO_ :: H.HashMap IODependency_ Result_ - -- , cDBus :: H.HashMap DBusDependency_ Result_ +data Cache = Cache + { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p) + cIO_ :: H.HashMap IODependency_ Result_ + , cDBus_ :: H.HashMap DBusDependency_ Result_ } -emptyCache :: Cache -emptyCache = Cache H.empty +-- class Memoizable a + -- cache :: a -> -memoizeSys :: (SystemDependency -> IO Result_) -> SystemDependency -> FIO Result_ -memoizeSys f d = do - m <- gets cSys - let r = H.lookup d m - maybe (io $ f d) return r +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 r + Nothing -> do + -- io $ putStrLn $ "not using cache for " ++ show d + r <- f d + modify (\s -> s { cIO_ = H.insert d r (cIO_ s) }) + return r + +memoizeDBus_ :: (DBusDependency_ -> FIO Result_) -> DBusDependency_ -> FIO Result_ +memoizeDBus_ f d = do + m <- gets cDBus_ + case H.lookup d m of + (Just r) -> return r + Nothing -> do + -- io $ putStrLn $ "not using cache for " ++ show d + r <- f d + modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) }) + return r -------------------------------------------------------------------------------- -- | Testing pipeline @@ -497,9 +534,12 @@ testTree_ test = go test2nd ws = fmap ((Right . (ws ++)) =<<) . go testIODependency_ :: IODependency_ -> FIO Result_ -testIODependency_ (IOSystem_ s) = memoizeSys (fmap readResult_ . testSysDependency) s -testIODependency_ (IOTest_ _ t) = io $ readResult_ <$> t -testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x +testIODependency_ = memoizeIO_ testIODependency'_ + +testIODependency'_ :: IODependency_ -> FIO Result_ +testIODependency'_ (IOSystem_ s) = io $ readResult_ <$> testSysDependency s +testIODependency'_ (IOTest_ _ t) = io $ readResult_ <$> t +testIODependency'_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x -------------------------------------------------------------------------------- -- | System Dependency Testing @@ -549,7 +589,10 @@ introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_ -testDBusDependency_ client (Bus bus) = io $ do +testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl) + +testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_ +testDBusDependency'_ client (Bus bus) = io $ do ret <- callMethod client queryBus queryPath queryIface queryMem return $ case ret of Left e -> Left [e] @@ -565,7 +608,7 @@ testDBusDependency_ client (Bus bus) = io $ do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -testDBusDependency_ client (Endpoint busname objpath iface mem) = io $ do +testDBusDependency'_ client (Endpoint busname objpath iface mem) = io $ do ret <- callMethod client busname objpath introspectInterface introspectMethod return $ case ret of Left e -> Left [e] @@ -595,7 +638,7 @@ testDBusDependency_ client (Endpoint busname objpath iface mem) = io $ do , formatBusName busname ] -testDBusDependency_ _ (DBusIO i) = testIODependency_ i +testDBusDependency'_ _ (DBusIO i) = testIODependency_ i -------------------------------------------------------------------------------- -- | IO Lifting functions diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 1142e52..a8475fe 100644 --- a/my-xmonad.cabal +++ b/my-xmonad.cabal @@ -8,6 +8,7 @@ library exposed-modules: XMonad.Internal.Concurrent.ClientMessage , XMonad.Internal.Concurrent.ACPIEvent , XMonad.Internal.Concurrent.DynamicWorkspaces + , XMonad.Internal.Concurrent.VirtualBox , XMonad.Internal.Theme , XMonad.Internal.Notify , XMonad.Internal.Shell @@ -56,6 +57,7 @@ library , aeson >= 2.0.3.0 , unordered-containers >= 0.2.16.0 , hashable >= 1.3.5.0 + , xml >= 1.3.14 ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures default-language: Haskell2010