ENH use faster function for finding VMs
This commit is contained in:
parent
7cfb799698
commit
c292c2b9a8
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue