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