ENH use faster function for finding VMs

This commit is contained in:
Nathan Dwarshuis 2022-07-06 00:16:47 -04:00
parent 7cfb799698
commit c292c2b9a8
3 changed files with 80 additions and 36 deletions

View File

@ -24,9 +24,7 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import System.Environment import System.Environment
import System.Exit
import System.IO import System.IO
import System.IO.Error
import System.Process import System.Process
import XMonad import XMonad
@ -48,6 +46,7 @@ import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ACPIEvent import XMonad.Internal.Concurrent.ACPIEvent
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Internal.Concurrent.DynamicWorkspaces import XMonad.Internal.Concurrent.DynamicWorkspaces
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
@ -275,15 +274,15 @@ vmDynamicWorkspace = sometimes1 "virtualbox workspace" "windows 8 VM" root
, dwCmd = Just $ spawnCmd "vbox-start" [vm] , dwCmd = Just $ spawnCmd "vbox-start" [vm]
} }
-- TODO this shell command is hilariously slow and kills my fast startup time -- -- TODO this shell command is hilariously slow and kills my fast startup time
vmExists :: String -> IO (Maybe String) -- vmExists :: String -> IO (Maybe String)
vmExists vm = -- vmExists vm =
go <$> tryIOError (readCreateProcessWithExitCode' pr "") -- go <$> tryIOError (readCreateProcessWithExitCode' pr "")
where -- where
pr = proc' "VBoxManage" ["showvminfo", vm] -- pr = proc' "VBoxManage" ["showvminfo", vm]
go (Right (ExitSuccess, _, _)) = Nothing -- go (Right (ExitSuccess, _, _)) = Nothing
go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm -- go (Right (ExitFailure _, _, _)) = Just $ "VM not found: " ++ vm
go (Left e) = Just $ show e -- go (Left e) = Just $ show e
xsaneDynamicWorkspace :: Sometimes DynWorkspace xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = sometimesIO_ "scanner workspace" "xsane" tree dw xsaneDynamicWorkspace = sometimesIO_ "scanner workspace" "xsane" tree dw

View File

@ -104,7 +104,7 @@ import Data.Maybe
import GHC.Generics (Generic) import GHC.Generics (Generic)
import DBus import DBus hiding (typeOf)
import DBus.Client import DBus.Client
import DBus.Internal import DBus.Internal
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
@ -287,17 +287,31 @@ data IODependency p =
data DBusDependency_ = Bus BusName data DBusDependency_ = Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember | Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | 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) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ SystemDependency data IODependency_ = IOSystem_ SystemDependency
| IOTest_ String (IO (Maybe String)) | IOTest_ String (IO (Maybe String))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
-- instance Eq IODependency_ where instance Eq IODependency_ where
-- (==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1 (==) (IOSystem_ s0) (IOSystem_ s1) = s0 == s1
-- (==) (IOTest_ _ _) (IOTest_ _ _) = False (==) (IOTest_ _ _) (IOTest_ _ _) = False
-- (==) (IOSometimes_ _) (IOSometimes_ _) = False (==) (IOSometimes_ _) (IOSometimes_ _) = False
-- (==) _ _ = 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 -- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious -- This name is dumb, but most constructors should be obvious
@ -318,7 +332,12 @@ instance Hashable UnitType
data DBusMember = Method_ MemberName data DBusMember = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ String | 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 -- | Tested dependency tree
@ -363,21 +382,39 @@ data PostFail = PostFail [String] | PostMissing String
type FIO a = StateT Cache IO a type FIO a = StateT Cache IO a
newtype Cache = Cache data Cache = Cache
{ cSys :: H.HashMap SystemDependency Result_ { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
-- , cIO :: forall p. H.HashMap (IODependency p) (Result p) cIO_ :: H.HashMap IODependency_ Result_
-- , cIO_ :: H.HashMap IODependency_ Result_ , cDBus_ :: H.HashMap DBusDependency_ Result_
-- , cDBus :: H.HashMap DBusDependency_ Result_
} }
emptyCache :: Cache -- class Memoizable a
emptyCache = Cache H.empty -- cache :: a ->
memoizeSys :: (SystemDependency -> IO Result_) -> SystemDependency -> FIO Result_ emptyCache :: Cache
memoizeSys f d = do emptyCache = Cache H.empty H.empty
m <- gets cSys
let r = H.lookup d m memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
maybe (io $ f d) return r 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 -- | Testing pipeline
@ -497,9 +534,12 @@ testTree_ test = go
test2nd ws = fmap ((Right . (ws ++)) =<<) . go test2nd ws = fmap ((Right . (ws ++)) =<<) . go
testIODependency_ :: IODependency_ -> FIO Result_ testIODependency_ :: IODependency_ -> FIO Result_
testIODependency_ (IOSystem_ s) = memoizeSys (fmap readResult_ . testSysDependency) s testIODependency_ = memoizeIO_ testIODependency'_
testIODependency_ (IOTest_ _ t) = io $ readResult_ <$> t
testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x 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 -- | System Dependency Testing
@ -549,7 +589,10 @@ introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect" introspectMethod = memberName_ "Introspect"
testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_ 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 ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [e]
@ -565,7 +608,7 @@ testDBusDependency_ client (Bus bus) = io $ do
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
bodyGetNames _ = [] 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 ret <- callMethod client busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [e] Left e -> Left [e]
@ -595,7 +638,7 @@ testDBusDependency_ client (Endpoint busname objpath iface mem) = io $ do
, formatBusName busname , formatBusName busname
] ]
testDBusDependency_ _ (DBusIO i) = testIODependency_ i testDBusDependency'_ _ (DBusIO i) = testIODependency_ i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Lifting functions -- | IO Lifting functions

View File

@ -8,6 +8,7 @@ library
exposed-modules: XMonad.Internal.Concurrent.ClientMessage exposed-modules: XMonad.Internal.Concurrent.ClientMessage
, XMonad.Internal.Concurrent.ACPIEvent , XMonad.Internal.Concurrent.ACPIEvent
, XMonad.Internal.Concurrent.DynamicWorkspaces , XMonad.Internal.Concurrent.DynamicWorkspaces
, XMonad.Internal.Concurrent.VirtualBox
, XMonad.Internal.Theme , XMonad.Internal.Theme
, XMonad.Internal.Notify , XMonad.Internal.Notify
, XMonad.Internal.Shell , XMonad.Internal.Shell
@ -56,6 +57,7 @@ library
, aeson >= 2.0.3.0 , aeson >= 2.0.3.0
, unordered-containers >= 0.2.16.0 , unordered-containers >= 0.2.16.0
, hashable >= 1.3.5.0 , hashable >= 1.3.5.0
, xml >= 1.3.14
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010