ADD awkwardly unify path dependencies into dependency module
This commit is contained in:
parent
76c0eb3386
commit
952e10b1a5
|
@ -81,8 +81,9 @@ main = do
|
||||||
, childPIDs = [p]
|
, childPIDs = [p]
|
||||||
, childHandles = [h]
|
, childHandles = [h]
|
||||||
}
|
}
|
||||||
(ekbs, missing) <- fmap filterExternal $ evalExternal $ externalBindings bc sc ts
|
ext <- evalExternal $ externalBindings bc sc ts
|
||||||
mapM_ warnMissing missing
|
let ekbs = filterExternal ext
|
||||||
|
warnMissing $ externalToMissing ext
|
||||||
-- IDK why this is necessary; nothing prior to this line will print if missing
|
-- IDK why this is necessary; nothing prior to this line will print if missing
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
launch
|
launch
|
||||||
|
@ -479,18 +480,32 @@ evalExternal = mapM go
|
||||||
evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
|
evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
|
||||||
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
|
evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
|
||||||
|
|
||||||
filterExternal :: [KeyGroup MaybeX] -> ([KeyGroup (X ())], [Dependency])
|
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
|
||||||
filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs')
|
filterExternal = fmap go
|
||||||
where
|
where
|
||||||
go k@KeyGroup { kgBindings = bs } = let bs' = go' <$> bs in
|
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
|
||||||
(k { kgBindings = mapMaybe fst bs' }, concatMap snd bs')
|
-- go k@KeyGroup { kgBindings = bs } =
|
||||||
go' k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
|
-- ( k { kgBindings = mapMaybe flagKeyBinding bs }
|
||||||
Installed x ds -> (Just $ k{ kbAction = x }, ds)
|
-- , concatMap go' bs
|
||||||
Missing ds -> (Just $ k{ kbDesc = flagMissing d, kbAction = skip }, ds)
|
-- )
|
||||||
Ignore -> (Nothing, [])
|
-- go' KeyBinding{ kbAction = a } = case a of
|
||||||
flagMissing s = "[!!!]" ++ s
|
-- Installed _ opt -> opt
|
||||||
|
-- -- TODO this will mash together the optional and required deps
|
||||||
|
-- Missing req opt -> req ++ opt
|
||||||
|
-- Ignore -> []
|
||||||
|
|
||||||
externalBindings :: Maybe BrightnessControls
|
externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
|
||||||
|
externalToMissing = concatMap go
|
||||||
|
where
|
||||||
|
go KeyGroup { kgBindings = bs } = fmap kbAction bs
|
||||||
|
|
||||||
|
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
|
||||||
|
flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
|
||||||
|
Installed x _ -> Just $ k{ kbAction = x }
|
||||||
|
Missing _ _ -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip }
|
||||||
|
Ignore -> Nothing
|
||||||
|
|
||||||
|
externalBindings :: BrightnessControls
|
||||||
-> MaybeExe SSControls
|
-> MaybeExe SSControls
|
||||||
-> ThreadState
|
-> ThreadState
|
||||||
-> [KeyGroup (IO MaybeX)]
|
-> [KeyGroup (IO MaybeX)]
|
||||||
|
@ -539,10 +554,10 @@ externalBindings bc sc ts =
|
||||||
]
|
]
|
||||||
|
|
||||||
, KeyGroup "System"
|
, KeyGroup "System"
|
||||||
[ KeyBinding "M-." "backlight up" $ runMaybe bc bctlInc
|
[ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc
|
||||||
, KeyBinding "M-," "backlight down" $ runMaybe bc bctlDec
|
, KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc
|
||||||
, KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin
|
, KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc
|
||||||
, KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax
|
, KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc
|
||||||
, KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
|
, KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
|
||||||
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
|
, KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
|
||||||
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
|
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
|
||||||
|
@ -558,8 +573,8 @@ externalBindings bc sc ts =
|
||||||
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
-- where
|
||||||
-- TODO this is hacky, I shouldn't really need this data structure for
|
-- TODO this is hacky, I shouldn't really need this data structure for
|
||||||
-- something that doesn't depend on executables
|
-- something that doesn't depend on executables
|
||||||
runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
|
-- runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Brightness.Common
|
||||||
, matchSignal
|
, matchSignal
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void, when)
|
||||||
|
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
|
|
||||||
|
@ -17,6 +17,7 @@ import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
import XMonad.Internal.Dependency
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | External API
|
-- | External API
|
||||||
|
@ -38,24 +39,26 @@ data BrightnessConfig a b = BrightnessConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
data BrightnessControls = BrightnessControls
|
data BrightnessControls = BrightnessControls
|
||||||
{ bctlMax :: IO ()
|
{ bctlMax :: MaybeExe (IO ())
|
||||||
, bctlMin :: IO ()
|
, bctlMin :: MaybeExe (IO ())
|
||||||
, bctlInc :: IO ()
|
, bctlInc :: MaybeExe (IO ())
|
||||||
, bctlDec :: IO ()
|
, bctlDec :: MaybeExe (IO ())
|
||||||
}
|
}
|
||||||
|
|
||||||
exportBrightnessControls :: RealFrac b => BrightnessConfig a b -> Client
|
exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
||||||
-> IO BrightnessControls
|
-> Client -> IO BrightnessControls
|
||||||
exportBrightnessControls bc client = do
|
exportBrightnessControls deps bc client = do
|
||||||
exportBrightnessControls' bc client
|
(req, opt) <- checkInstalled deps
|
||||||
|
when (null req) $
|
||||||
|
exportBrightnessControls' bc client
|
||||||
return $ BrightnessControls
|
return $ BrightnessControls
|
||||||
{ bctlMax = callBacklight' memMax
|
{ bctlMax = callBacklight' req opt memMax
|
||||||
, bctlMin = callBacklight' memMin
|
, bctlMin = callBacklight' req opt memMin
|
||||||
, bctlInc = callBacklight' memInc
|
, bctlInc = callBacklight' req opt memInc
|
||||||
, bctlDec = callBacklight' memDec
|
, bctlDec = callBacklight' req opt memDec
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
callBacklight' = callBacklight bc
|
callBacklight' r o = createInstalled r o . callBacklight bc
|
||||||
|
|
||||||
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
|
callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
|
||||||
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
|
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
|
||||||
|
|
|
@ -5,11 +5,11 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
( callGetBrightnessIB
|
( callGetBrightnessIB
|
||||||
, matchSignalIB
|
, matchSignalIB
|
||||||
, exportIntelBacklight
|
, exportIntelBacklight
|
||||||
, hasBacklight
|
-- , hasBacklight
|
||||||
, blPath
|
, blPath
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Either
|
-- import Data.Either
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
@ -18,6 +18,7 @@ import DBus.Client
|
||||||
import System.FilePath.Posix
|
import System.FilePath.Posix
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
|
import XMonad.Internal.Dependency
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -64,29 +65,29 @@ decBrightness = decPercent steps curFile
|
||||||
-- Right True -> backlight accessible and present
|
-- Right True -> backlight accessible and present
|
||||||
-- Right False -> backlight not present
|
-- Right False -> backlight not present
|
||||||
-- Left x -> backlight present but could not access (x explaining why)
|
-- Left x -> backlight present but could not access (x explaining why)
|
||||||
hasBacklight' :: IO (Either String Bool)
|
-- hasBacklight' :: IO (Either String Bool)
|
||||||
hasBacklight' = do
|
-- hasBacklight' = do
|
||||||
mx <- isReadable maxFile
|
-- mx <- isReadable maxFile
|
||||||
cx <- isWritable curFile
|
-- cx <- isWritable curFile
|
||||||
return $ case (mx, cx) of
|
-- return $ case (mx, cx) of
|
||||||
(NotFoundError, NotFoundError) -> Right False
|
-- (NotFoundError, NotFoundError) -> Right False
|
||||||
(PermResult True, PermResult True) -> Right True
|
-- (PermResult True, PermResult True) -> Right True
|
||||||
(PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
|
-- (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
|
||||||
_ -> Left "Could not determine permissions for backlight files"
|
-- _ -> Left "Could not determine permissions for backlight files"
|
||||||
|
|
||||||
msg :: Either String Bool -> IO ()
|
-- msg :: Either String Bool -> IO ()
|
||||||
msg (Right True) = return ()
|
-- msg (Right True) = return ()
|
||||||
msg (Right False) = putStrLn "No backlight detected. Controls disabled"
|
-- msg (Right False) = putStrLn "No backlight detected. Controls disabled"
|
||||||
msg (Left m) = putStrLn $ "WARNING: " ++ m
|
-- msg (Left m) = putStrLn $ "WARNING: " ++ m
|
||||||
|
|
||||||
hasBacklightMsg :: IO Bool
|
-- hasBacklightMsg :: IO Bool
|
||||||
hasBacklightMsg = do
|
-- hasBacklightMsg = do
|
||||||
b <- hasBacklight'
|
-- b <- hasBacklight'
|
||||||
msg b
|
-- msg b
|
||||||
return $ fromRight False b
|
-- return $ fromRight False b
|
||||||
|
|
||||||
hasBacklight :: IO Bool
|
-- hasBacklight :: IO Bool
|
||||||
hasBacklight = fromRight False <$> hasBacklight'
|
-- hasBacklight = fromRight False <$> hasBacklight'
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus interface
|
-- | DBus interface
|
||||||
|
@ -112,12 +113,14 @@ intelBacklightConfig = BrightnessConfig
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
exportIntelBacklight :: Client -> IO (Maybe BrightnessControls)
|
exportIntelBacklight :: Client -> IO BrightnessControls
|
||||||
exportIntelBacklight client = do
|
exportIntelBacklight = exportBrightnessControls deps intelBacklightConfig
|
||||||
b <- hasBacklightMsg
|
where
|
||||||
if b
|
deps = [pathRW curFile, pathR maxFile]
|
||||||
then Just <$> exportBrightnessControls intelBacklightConfig client
|
-- b <- hasBacklightMsg
|
||||||
else return Nothing
|
-- if b
|
||||||
|
-- then Just <$> exportBrightnessControls intelBacklightConfig client
|
||||||
|
-- else return Nothing
|
||||||
|
|
||||||
callGetBrightnessIB :: IO (Maybe Brightness)
|
callGetBrightnessIB :: IO (Maybe Brightness)
|
||||||
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
callGetBrightnessIB = callGetBrightness intelBacklightConfig
|
||||||
|
|
|
@ -31,29 +31,37 @@ introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
data DBusXMonad = DBusXMonad
|
data DBusXMonad = DBusXMonad
|
||||||
{ dxClient :: Client
|
{ dxClient :: Client
|
||||||
, dxIntelBacklightCtrl :: Maybe BrightnessControls
|
, dxIntelBacklightCtrl :: BrightnessControls
|
||||||
, dxClevoBacklightCtrl :: Maybe BrightnessControls
|
-- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls
|
||||||
, dxScreensaverCtrl :: MaybeExe SSControls
|
, dxScreensaverCtrl :: MaybeExe SSControls
|
||||||
}
|
}
|
||||||
|
|
||||||
|
blankControls :: BrightnessControls
|
||||||
|
blankControls = BrightnessControls
|
||||||
|
{ bctlMax = Ignore
|
||||||
|
, bctlMin = Ignore
|
||||||
|
, bctlInc = Ignore
|
||||||
|
, bctlDec = Ignore
|
||||||
|
}
|
||||||
|
|
||||||
startXMonadService :: IO DBusXMonad
|
startXMonadService :: IO DBusXMonad
|
||||||
startXMonadService = do
|
startXMonadService = do
|
||||||
client <- connectSession
|
client <- connectSession
|
||||||
requestResult <- requestName client xmonadBus []
|
requestResult <- requestName client xmonadBus []
|
||||||
-- TODO if the client is not released on shutdown the owner will be
|
-- TODO if the client is not released on shutdown the owner will be
|
||||||
-- different
|
-- different
|
||||||
(i, c, s) <- if requestResult /= NamePrimaryOwner then do
|
(i, s) <- if requestResult /= NamePrimaryOwner then do
|
||||||
putStrLn "Another service owns \"org.xmonad\""
|
putStrLn "Another service owns \"org.xmonad\""
|
||||||
return (Nothing, Nothing, Ignore)
|
return (blankControls, Ignore)
|
||||||
else do
|
else do
|
||||||
putStrLn "Started xmonad dbus client"
|
putStrLn "Started xmonad dbus client"
|
||||||
bc <- exportIntelBacklight client
|
bc <- exportIntelBacklight client
|
||||||
sc <- exportScreensaver client
|
sc <- exportScreensaver client
|
||||||
return (bc, Nothing, sc)
|
return (bc, sc)
|
||||||
return $ DBusXMonad
|
return $ DBusXMonad
|
||||||
{ dxClient = client
|
{ dxClient = client
|
||||||
, dxIntelBacklightCtrl = i
|
, dxIntelBacklightCtrl = i
|
||||||
, dxClevoBacklightCtrl = c
|
-- , dxClevoBacklightCtrl = c
|
||||||
, dxScreensaverCtrl = s
|
, dxScreensaverCtrl = s
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -94,9 +94,9 @@ newtype SSControls = SSControls { ssToggle :: IO () }
|
||||||
|
|
||||||
exportScreensaver :: Client -> IO (MaybeExe SSControls)
|
exportScreensaver :: Client -> IO (MaybeExe SSControls)
|
||||||
exportScreensaver client = do
|
exportScreensaver client = do
|
||||||
d <- depInstalled dep
|
d <- depInstalled $ depData dep
|
||||||
if d then flip Installed [] <$> exportScreensaver' client
|
if d then flip Installed [] <$> exportScreensaver' client
|
||||||
else return $ Missing [dep]
|
else return $ Missing [depData dep] []
|
||||||
where
|
where
|
||||||
dep = exe "xset"
|
dep = exe "xset"
|
||||||
|
|
||||||
|
|
|
@ -5,10 +5,16 @@ module XMonad.Internal.Dependency
|
||||||
( MaybeExe(..)
|
( MaybeExe(..)
|
||||||
, UnitType(..)
|
, UnitType(..)
|
||||||
, Dependency(..)
|
, Dependency(..)
|
||||||
|
, DependencyData(..)
|
||||||
, MaybeX
|
, MaybeX
|
||||||
, exe
|
, exe
|
||||||
, systemUnit
|
, systemUnit
|
||||||
, userUnit
|
, userUnit
|
||||||
|
, pathR
|
||||||
|
, pathW
|
||||||
|
, pathRW
|
||||||
|
, checkInstalled
|
||||||
|
, createInstalled
|
||||||
, runIfInstalled
|
, runIfInstalled
|
||||||
, depInstalled
|
, depInstalled
|
||||||
, warnMissing
|
, warnMissing
|
||||||
|
@ -29,18 +35,19 @@ module XMonad.Internal.Dependency
|
||||||
, spawnSound
|
, spawnSound
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (filterM)
|
import Control.Arrow ((***))
|
||||||
|
import Control.Monad (filterM, join)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
|
import Data.List (partition)
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe (isJust)
|
||||||
|
|
||||||
-- import System.Directory (findExecutable, readable, writable)
|
import System.Directory (findExecutable, readable, writable)
|
||||||
import System.Directory (findExecutable)
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import XMonad.Core (X, getXMonadDir)
|
import XMonad.Core (X, getXMonadDir)
|
||||||
-- import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
import XMonad.Internal.Process
|
import XMonad.Internal.Process
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
|
@ -49,61 +56,69 @@ import XMonad.Internal.Shell
|
||||||
|
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||||
|
|
||||||
data DependencyType = Executable
|
data DependencyData = Executable String
|
||||||
-- | AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| Systemd UnitType deriving (Eq, Show)
|
| Systemd UnitType String
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data Dependency = Dependency
|
data Dependency = Dependency
|
||||||
{ depRequired :: Bool
|
{ depRequired :: Bool
|
||||||
, depName :: String
|
, depData :: DependencyData
|
||||||
, depType :: DependencyType
|
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
exe :: String -> Dependency
|
exe :: String -> Dependency
|
||||||
exe n = Dependency
|
exe n = Dependency
|
||||||
{ depRequired = True
|
{ depRequired = True
|
||||||
, depName = n
|
, depData = Executable n
|
||||||
, depType = Executable
|
|
||||||
}
|
}
|
||||||
|
|
||||||
unit :: UnitType -> String -> Dependency
|
unit :: UnitType -> String -> Dependency
|
||||||
unit t n = Dependency
|
unit t n = Dependency
|
||||||
{ depRequired = True
|
{ depRequired = True
|
||||||
, depName = n
|
, depData = Systemd t n
|
||||||
, depType = Systemd t
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
path :: Bool -> Bool -> String -> Dependency
|
||||||
|
path r w n = Dependency
|
||||||
|
{ depRequired = True
|
||||||
|
, depData = AccessiblePath n r w
|
||||||
|
}
|
||||||
|
|
||||||
|
pathR :: String -> Dependency
|
||||||
|
pathR = path True False
|
||||||
|
|
||||||
|
pathW :: String -> Dependency
|
||||||
|
pathW = path False True
|
||||||
|
|
||||||
|
pathRW :: String -> Dependency
|
||||||
|
pathRW = path True True
|
||||||
|
|
||||||
systemUnit :: String -> Dependency
|
systemUnit :: String -> Dependency
|
||||||
systemUnit = unit SystemUnit
|
systemUnit = unit SystemUnit
|
||||||
|
|
||||||
userUnit :: String -> Dependency
|
userUnit :: String -> Dependency
|
||||||
userUnit = unit UserUnit
|
userUnit = unit UserUnit
|
||||||
|
|
||||||
data MaybeExe a = Installed a [Dependency] | Missing [Dependency] | Ignore
|
-- TODO this is poorly named. This actually represents an action that has
|
||||||
|
-- one or more dependencies (where "action" is not necessarily executing an exe)
|
||||||
|
data MaybeExe a = Installed a [DependencyData]
|
||||||
|
| Missing [DependencyData] [DependencyData]
|
||||||
|
| Ignore
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Functor MaybeExe where
|
instance Functor MaybeExe where
|
||||||
fmap f (Installed x ds) = Installed (f x) ds
|
fmap f (Installed x ds) = Installed (f x) ds
|
||||||
fmap _ (Missing x) = Missing x
|
fmap _ (Missing req opt) = Missing req opt
|
||||||
fmap _ Ignore = Ignore
|
fmap _ Ignore = Ignore
|
||||||
|
|
||||||
type MaybeX = MaybeExe (X ())
|
type MaybeX = MaybeExe (X ())
|
||||||
|
|
||||||
warnMissing :: Dependency -> IO ()
|
|
||||||
warnMissing Dependency {depRequired = r, depName = n, depType = t } =
|
|
||||||
putStrLn $ "WARNING: " ++ r' ++ " " ++ fmtType t ++ " not found: " ++ n
|
|
||||||
where
|
|
||||||
fmtType Executable = "executable"
|
|
||||||
-- fmtType (AccessiblePath _ _ _) = undefined
|
|
||||||
fmtType (Systemd UserUnit) = "systemd user unit"
|
|
||||||
fmtType (Systemd SystemUnit) = "systemd system unit"
|
|
||||||
r' = if r then "required" else "optional"
|
|
||||||
|
|
||||||
exeInstalled :: String -> IO Bool
|
exeInstalled :: String -> IO Bool
|
||||||
exeInstalled x = isJust <$> findExecutable x
|
exeInstalled x = isJust <$> findExecutable x
|
||||||
|
|
||||||
unitInstalled :: String -> UnitType -> IO Bool
|
unitInstalled :: UnitType -> String -> IO Bool
|
||||||
unitInstalled x u = do
|
unitInstalled u x = do
|
||||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||||
return $ case rc of
|
return $ case rc of
|
||||||
ExitSuccess -> True
|
ExitSuccess -> True
|
||||||
|
@ -112,38 +127,56 @@ unitInstalled x u = do
|
||||||
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
|
cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
|
||||||
|
|
||||||
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
-- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
|
||||||
-- pathAccessible p testread testwrite = do
|
pathAccessible :: FilePath -> Bool -> Bool -> IO Bool
|
||||||
-- res <- getPermissionsSafe p
|
pathAccessible p testread testwrite = do
|
||||||
-- let msg = permMsg res
|
res <- getPermissionsSafe p
|
||||||
-- return $ fmap (\m -> m ++ ": " ++ p) msg
|
let msg = permMsg res
|
||||||
-- where
|
return msg
|
||||||
-- testPerm False _ _ = Nothing
|
-- return $ fmap (\m -> m ++ ": " ++ p) msg
|
||||||
-- testPerm True f r = Just $ f r
|
where
|
||||||
-- permMsg NotFoundError = Just "file not found"
|
testPerm False _ _ = Nothing
|
||||||
-- permMsg PermError = Just "could not get permissions"
|
testPerm True f r = Just $ f r
|
||||||
-- permMsg (PermResult r) =
|
-- permMsg NotFoundError = Just "file not found"
|
||||||
-- case (testPerm testread readable r, testPerm testwrite writable r) of
|
-- permMsg PermError = Just "could not get permissions"
|
||||||
-- (Just False, Just False) -> Just "file not readable or writable"
|
permMsg NotFoundError = False
|
||||||
-- (Just False, _) -> Just "file not readable"
|
permMsg PermError = False
|
||||||
-- (_, Just False) -> Just "file not writable"
|
permMsg (PermResult r) =
|
||||||
-- _ -> Nothing
|
case (testPerm testread readable r, testPerm testwrite writable r) of
|
||||||
|
-- (Just False, Just False) -> Just "file not readable or writable"
|
||||||
|
-- (Just False, _) -> Just "file not readable"
|
||||||
|
-- (_, Just False) -> Just "file not writable"
|
||||||
|
-- _ -> Nothing
|
||||||
|
(Just True, Just True) -> True
|
||||||
|
(Just True, Nothing) -> True
|
||||||
|
(Nothing, Just True) -> True
|
||||||
|
_ -> False
|
||||||
|
-- (Just False, Just False) -> Just "file not readable or writable"
|
||||||
|
-- (Just False, _) -> Just "file not readable"
|
||||||
|
-- (_, Just False) -> Just "file not writable"
|
||||||
|
-- _ -> Nothing
|
||||||
|
|
||||||
depInstalled :: Dependency -> IO Bool
|
-- TODO somehow get this to preserve error messages if something isn't found
|
||||||
depInstalled Dependency { depName = n, depType = t } =
|
depInstalled :: DependencyData -> IO Bool
|
||||||
case t of
|
depInstalled (Executable n) = exeInstalled n
|
||||||
Executable -> exeInstalled n
|
depInstalled (Systemd t n) = unitInstalled t n
|
||||||
|
depInstalled (AccessiblePath p r w) = pathAccessible p r w
|
||||||
-- (AccessiblePath p r w) -> pathAccessible p r w
|
-- (AccessiblePath p r w) -> pathAccessible p r w
|
||||||
Systemd u -> unitInstalled n u
|
|
||||||
|
checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData])
|
||||||
|
checkInstalled = fmap go . filterMissing
|
||||||
|
where
|
||||||
|
go = join (***) (fmap depData) . partition depRequired
|
||||||
|
|
||||||
|
createInstalled :: [DependencyData] -> [DependencyData] -> a -> MaybeExe a
|
||||||
|
createInstalled req opt x = if null req then Installed x opt else Missing req opt
|
||||||
|
|
||||||
filterMissing :: [Dependency] -> IO [Dependency]
|
filterMissing :: [Dependency] -> IO [Dependency]
|
||||||
filterMissing = filterM (fmap not . depInstalled)
|
filterMissing = filterM (fmap not . depInstalled . depData)
|
||||||
|
|
||||||
runIfInstalled :: MonadIO m => [Dependency] -> m () -> IO (MaybeExe (m ()))
|
runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
|
||||||
runIfInstalled ds x = do
|
runIfInstalled ds x = do
|
||||||
missing <- filterMissing ds
|
(req, opt) <- checkInstalled ds
|
||||||
return $ if not $ any depRequired missing
|
return $ createInstalled req opt x
|
||||||
then Installed x $ filter (not . depRequired) missing
|
|
||||||
else Missing missing
|
|
||||||
|
|
||||||
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
|
spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
|
||||||
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
|
spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
|
||||||
|
@ -172,6 +205,42 @@ spawnSound file pre post = runIfInstalled [exe "paplay"]
|
||||||
|
|
||||||
playSound :: MonadIO m => FilePath -> m ()
|
playSound :: MonadIO m => FilePath -> m ()
|
||||||
playSound file = do
|
playSound file = do
|
||||||
path <- (</> soundDir </> file) <$> getXMonadDir
|
p <- (</> soundDir </> file) <$> getXMonadDir
|
||||||
-- paplay seems to have less latency than aplay
|
-- paplay seems to have less latency than aplay
|
||||||
spawnCmd "paplay" [path]
|
spawnCmd "paplay" [p]
|
||||||
|
|
||||||
|
partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
|
||||||
|
partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
|
||||||
|
where
|
||||||
|
go (Installed _ opt) = ([], opt)
|
||||||
|
go (Missing req opt) = (req, opt)
|
||||||
|
go Ignore = ([], [])
|
||||||
|
|
||||||
|
fmtMissing :: DependencyData -> String
|
||||||
|
-- TODO this error message is lame
|
||||||
|
fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
|
||||||
|
fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
|
||||||
|
fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
|
||||||
|
fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
|
||||||
|
fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
|
||||||
|
fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
|
||||||
|
++ n ++ "' not found"
|
||||||
|
where
|
||||||
|
unitType SystemUnit = "system"
|
||||||
|
unitType UserUnit = "user"
|
||||||
|
|
||||||
|
fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
|
||||||
|
fmtMsgs req opt = ("[WARNING] "++)
|
||||||
|
<$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
|
||||||
|
++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
|
||||||
|
|
||||||
|
warnMissing :: [MaybeExe a] -> IO ()
|
||||||
|
warnMissing = mapM_ putStrLn . uncurry fmtMsgs . partitionMissing
|
||||||
|
|
||||||
|
-- fmtType (AccessiblePath _ _ _) = undefined
|
||||||
|
|
||||||
|
-- splitDeps :: [MaybeExe a] -> ([a], [String])
|
||||||
|
-- splitDeps xs = undefined
|
||||||
|
|
||||||
|
-- splitDeps' :: [m (MaybeExe a)] -> ([m a], [String])
|
||||||
|
-- splitDeps' xs = undefined
|
||||||
|
|
|
@ -17,9 +17,10 @@ module XMonad.Internal.IO
|
||||||
, writePercentMax
|
, writePercentMax
|
||||||
, decPercent
|
, decPercent
|
||||||
, incPercent
|
, incPercent
|
||||||
, isReadable
|
-- , isReadable
|
||||||
, isWritable
|
-- , isWritable
|
||||||
, PermResult(..)
|
, PermResult(..)
|
||||||
|
, getPermissionsSafe
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
@ -99,10 +100,10 @@ decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
||||||
data PermResult a = PermResult a | NotFoundError | PermError
|
data PermResult a = PermResult a | NotFoundError | PermError
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
instance Functor PermResult where
|
-- instance Functor PermResult where
|
||||||
fmap f (PermResult r) = PermResult $ f r
|
-- fmap f (PermResult r) = PermResult $ f r
|
||||||
fmap _ NotFoundError = NotFoundError
|
-- fmap _ NotFoundError = NotFoundError
|
||||||
fmap _ PermError = PermError
|
-- fmap _ PermError = PermError
|
||||||
|
|
||||||
getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
|
getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
|
||||||
getPermissionsSafe f = do
|
getPermissionsSafe f = do
|
||||||
|
@ -115,8 +116,8 @@ getPermissionsSafe f = do
|
||||||
-- so the catchall case should never happen
|
-- so the catchall case should never happen
|
||||||
_ -> error "Unknown permission error"
|
_ -> error "Unknown permission error"
|
||||||
|
|
||||||
isReadable :: FilePath -> IO (PermResult Bool)
|
-- isReadable :: FilePath -> IO (PermResult Bool)
|
||||||
isReadable = fmap (fmap readable) . getPermissionsSafe
|
-- isReadable = fmap (fmap readable) . getPermissionsSafe
|
||||||
|
|
||||||
isWritable :: FilePath -> IO (PermResult Bool)
|
-- isWritable :: FilePath -> IO (PermResult Bool)
|
||||||
isWritable = fmap (fmap writable) . getPermissionsSafe
|
-- isWritable = fmap (fmap writable) . getPermissionsSafe
|
||||||
|
|
Loading…
Reference in New Issue