From a796cedcf63e87da2bc071c8bfae3a276bdff3b8 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sat, 2 Jul 2022 17:09:21 -0400 Subject: [PATCH] ENH use font features --- bin/xmobar.hs | 124 ++++++++++++-------- bin/xmonad.hs | 12 +- install_deps | 4 +- lib/XMonad/Internal/Command/DMenu.hs | 8 +- lib/XMonad/Internal/Command/Desktop.hs | 18 +-- lib/XMonad/Internal/Command/Power.hs | 63 ++++++---- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 20 ++-- lib/XMonad/Internal/Dependency.hs | 92 +++++++++------ lib/XMonad/Internal/Theme.hs | 73 +++++++----- 9 files changed, 258 insertions(+), 156 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 34b6313..f8167f7 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -52,20 +52,20 @@ main :: IO () main = do sysClient <- getDBusClient True sesClient <- getDBusClient False + ff <- evalFonts cs <- getAllCommands =<< rightPlugins sysClient sesClient d <- cfgDir <$> getDirectories -- this is needed to see any printed messages hFlush stdout mapM_ (maybe skip disconnect) [sysClient, sesClient] - xmobar $ config cs d + xmobar $ config ff cs d -config :: BarRegions -> String -> Config -config br confDir = defaultConfig - -- TODO head makes me feel icky - { font = head allFontStrings - , additionalFonts = drop 1 allFontStrings - , textOffset = head allFontOffsets - , textOffsets = drop 1 allFontOffsets +config :: (BarFont -> BarMetaFont) -> BarRegions -> String -> Config +config ff br confDir = defaultConfig + { font = fontString ff firstFont + , additionalFonts = fontString ff <$> restFonts + , textOffset = fontOffset ff firstFont + , textOffsets = fontOffset ff <$> restFonts , bgColor = T.bgColor , fgColor = T.fgColor , position = BottomSize C 100 24 @@ -255,14 +255,14 @@ readInterface n f = IORead n go return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs vpnPresent :: IO (Maybe String) -vpnPresent = do - res <- tryIOError $ readProcessWithExitCode "nmcli" args "" - -- TODO provide some error messages - return $ case res of - (Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found" - _ -> Just "puke" +vpnPresent = go <$> tryIOError (readProcessWithExitCode "nmcli" args "") where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] + go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing + else Just "vpn not found" + go (Right (ExitFailure c, _, err)) = Just $ "vpn search exited with code " + ++ show c ++ ": " ++ err + go (Left e) = Just $ show e xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface" @@ -298,7 +298,7 @@ getEthernet client = sometimes1 "ethernet status indicator" "sysfs path" readEth = readInterface "read ethernet interface" isEthernet getBattery :: BarFeature -getBattery = sometimesIO "battery level indicator" "sysfs path" +getBattery = sometimesIO_ "battery level indicator" "sysfs path" (Only_ $ sysTest "Test if battery is present" hasBattery) batteryCmd @@ -312,7 +312,7 @@ getBt :: Maybe Client -> BarFeature getBt = xmobarDBus "bluetooth status indicator" btDep btCmd getAlsa :: BarFeature -getAlsa = sometimesIO "volume level indicator" "alsactl" +getAlsa = sometimesIO_ "volume level indicator" "alsactl" (Only_ $ sysExe "alsactl") alsaCmd getBl :: Maybe Client -> BarFeature @@ -341,51 +341,83 @@ getAllCommands right = do -------------------------------------------------------------------------------- -- | fonts -data Font = Text +data BarFont = Text | IconSmall | IconMedium | IconLarge | IconXLarge deriving (Eq, Enum, Bounded, Show) +data BarMetaFont = BarMetaFont + { bfOffset :: Int + , bfBuilder :: T.FontBuilder + , bfFontData :: T.FontData + } + -- font data ~ (offset, fontification string) -fontData :: Font -> (Int, String) -fontData Text = (16, barFont) -fontData IconSmall = (16, nerdFont 13) -fontData IconMedium = (17, nerdFont 15) -fontData IconLarge = (17, nerdFont 18) -fontData IconXLarge = (18, nerdFont 20) +fontString :: (BarFont -> BarMetaFont) -> BarFont -> String +fontString f bf = b d + where + b = bfBuilder $ f bf + d = bfFontData $ f bf -fontString :: Font -> String -fontString = snd . fontData +fontOffset :: (BarFont -> BarMetaFont) -> BarFont -> Int +fontOffset f = bfOffset . f -fontOffset :: Font -> Int -fontOffset = fst . fontData +firstFont :: BarFont +firstFont = minBound -allFonts :: [Font] -allFonts = enumFrom minBound +restFonts :: [BarFont] +restFonts = enumFrom $ succ minBound -allFontOffsets :: [Int] -allFontOffsets = fontOffset <$> allFonts +-- allFonts :: [BarFont] +-- allFonts = enumFrom minBound -allFontStrings :: [String] -allFontStrings = fontString <$> allFonts +-- allFontOffsets :: [Int] +-- allFontOffsets = fontOffset <$> allFonts -barFont :: String -barFont = T.fmtFontXFT T.font - { T.family = "DejaVu Sans Mono" - , T.size = Just 11 - , T.weight = Just T.Bold - } +-- allFontStrings :: [String] +-- allFontStrings = fontString <$> allFonts -nerdFont :: Int -> String -nerdFont size = T.fmtFontXFT T.font - { T.family = "Symbols Nerd Font" - , T.size = Nothing - , T.pixelsize = Just size - } +barFont :: Always T.FontBuilder +barFont = T.fontFeature "XMobar Text Font" "DejaVu Sans Mono" -fontifyText :: Font -> String -> String +nerdFont :: Always T.FontBuilder +nerdFont = T.fontFeature "XMobar Icon Font" "Symbols Nerd Font" + +evalFonts :: IO (BarFont -> BarMetaFont) +evalFonts = do + bf <- evalAlways barFont + nf <- evalAlways nerdFont + return $ fontData bf nf + +fontData :: T.FontBuilder -> T.FontBuilder -> BarFont -> BarMetaFont +fontData barBuilder nerdBuilder bf = case bf of + Text -> BarMetaFont 16 barBuilder + $ T.defFontData { T.weight = Just T.Bold, T.size = Just 11 } + IconSmall -> nerd 16 13 + IconMedium -> nerd 17 15 + IconLarge -> nerd 17 18 + IconXLarge -> nerd 18 20 + where + nerd o s = BarMetaFont o nerdBuilder + $ T.defFontData { T.pixelsize = Just s, T.size = Nothing } + +-- barFont :: Always T.FontBuilder +-- barFont = T.fmtFontXFT T.font +-- { T.family = "DejaVu Sans Mono" +-- , T.size = Just 11 +-- , T.weight = Just T.Bold +-- } + +-- nerdFont :: Int -> String +-- nerdFont size = T.fmtFontXFT T.font +-- { T.family = "Symbols Nerd Font" +-- , T.size = Nothing +-- , T.pixelsize = Just size +-- } + +fontifyText :: BarFont -> String -> String fontifyText fnt txt = concat ["", txt, ""] -------------------------------------------------------------------------------- diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 8a3ecda..57fa9bd 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -92,6 +92,7 @@ run = do { tsChildPIDs = [p] , tsChildHandles = [h] } + fb <- evalAlways T.defFont ext <- evalExternal $ externalBindings ts db sk <- evalAlways runShowKeys ha <- evalAlways runHandleACPI @@ -103,7 +104,7 @@ run = do $ docks $ def { terminal = myTerm , modMask = myModMask - , layoutHook = myLayouts + , layoutHook = myLayouts fb , manageHook = myManageHook , handleEventHook = myEventHook ha , startupHook = myStartupHook @@ -262,12 +263,12 @@ allDWs = [ xsaneDynamicWorkspace -------------------------------------------------------------------------------- -- | Layout configuration -myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout +myLayouts fb = onWorkspace (dwTag wmDynamicWorkspace) vmLayout $ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout $ mkToggle (single HIDE) $ tall ||| fulltab ||| full where - addTopBar = noFrillsDeco shrinkText T.tabbedTheme + addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb tall = renamed [Replace "Tall"] $ avoidStruts $ addTopBar @@ -276,7 +277,7 @@ myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout fulltab = renamed [Replace "Tabbed"] $ avoidStruts $ noBorders - $ tabbedAlways shrinkText T.tabbedTheme + $ tabbedAlways shrinkText $ T.tabbedTheme fb full = renamed [Replace "Full"] $ noBorders Full vmLayout = noBorders Full @@ -610,7 +611,7 @@ externalBindings ts db = , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax , KeyBinding "M-" "power menu" $ Right runPowerPrompt - , KeyBinding "M-" "quit xmonad" quitf + , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt , KeyBinding "M-" "lock screen" $ Left runScreenLock -- M- reserved for showing the keymap , KeyBinding "M-" "restart xmonad" restartf @@ -630,7 +631,6 @@ externalBindings ts db = ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls ftrAlways n = Right . Always n . Always_ . FallbackAlone - quitf = ftrAlways "quit function" runQuitPrompt restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) recompilef = ftrAlways "recompile function" runRecompile diff --git a/install_deps b/install_deps index 06037f0..90c86a9 100755 --- a/install_deps +++ b/install_deps @@ -3,8 +3,8 @@ ## Install all pkgs required for xmonad to run at full capacity xmonad_pkgs=(autorandr feh xorg-server xorg-xset libpulse flameshot - playerctl wireless_tools acpid ttf-symbola-free ttf-symbola-free - ttf-dejavu awesome-terminal-fonts numlockx picom i3lock-color + playerctl acpid ttf-symbola-free ttf-symbola-free + ttf-dejavu numlockx picom i3lock-color xorg-xrandr xss-lock) yay --needed --noconfirm --norebuild --removemake -S "${xmonad_pkgs[@]}" diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index cbaa902..2d992e6 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity -- | Exported Commands runDevMenu :: SometimesX -runDevMenu = sometimesIO "device manager" "rofi devices" t x +runDevMenu = sometimesIO_ "device manager" "rofi devices" t x where t = Only_ $ localExe myDmenuDevices x = do @@ -87,12 +87,12 @@ runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False myDmenuBluetooth $ "-c":themeArgs "#0044bb" runBwMenu :: SometimesX -runBwMenu = sometimesIO "password manager" "rofi bitwarden" +runBwMenu = sometimesIO_ "password manager" "rofi bitwarden" (Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs runVPNMenu :: SometimesX -runVPNMenu = sometimesIO "VPN selector" "rofi VPN" +runVPNMenu = sometimesIO_ "VPN selector" "rofi VPN" (Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs @@ -103,7 +103,7 @@ runAppMenu :: SometimesX runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runClipMenu :: SometimesX -runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act +runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" deps act where act = spawnCmd myDmenuCmd args deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip") diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index f37c1bc..d46304f 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -95,7 +95,7 @@ runTerm :: SometimesX runTerm = sometimesExe "terminal" "urxvt" True myTerm runTMux :: SometimesX -runTMux = sometimesIO "terminal multiplexer" "tmux" deps act +runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act where deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"] act = spawn @@ -106,7 +106,7 @@ runTMux = sometimesIO "terminal multiplexer" "tmux" deps act msg = "could not connect to tmux session" runCalc :: SometimesX -runCalc = sometimesIO "calculator" "R" deps act +runCalc = sometimesIO_ "calculator" "R" deps act where deps = toAnd (sysExe myTerm) (sysExe "R") act = spawnCmd myTerm ["-e", "R"] @@ -155,7 +155,7 @@ playSound file = do featureSound :: String -> FilePath -> X () -> X () -> SometimesX featureSound n file pre post = - sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay") + sometimesIO_ ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay") $ pre >> playSound file >> post runVolumeDown :: SometimesX @@ -194,7 +194,7 @@ runNotificationContext = runToggleBluetooth :: SometimesX runToggleBluetooth = - sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth) + sometimesIO_ "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth) $ spawn $ myBluetooth ++ " show | grep -q \"Powered: no\"" #!&& "a=on" @@ -203,7 +203,7 @@ runToggleBluetooth = #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } runToggleEthernet :: SometimesX -runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli") +runToggleEthernet = sometimesIO_ "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli") $ spawn $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" #!&& "a=connect" @@ -212,7 +212,7 @@ runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } runStartISyncTimer :: SometimesX -runStartISyncTimer = sometimesIO "isync timer" "mbsync timer" +runStartISyncTimer = sometimesIO_ "isync timer" "mbsync timer" (Only_ $ sysdUser "mbsync.timer") $ spawn $ "systemctl --user start mbsync.timer" @@ -220,7 +220,7 @@ runStartISyncTimer = sometimesIO "isync timer" "mbsync timer" #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } runStartISyncService :: SometimesX -runStartISyncService = sometimesIO "isync" "mbsync service" +runStartISyncService = sometimesIO_ "isync" "mbsync service" (Only_ $ sysdUser "mbsync.service") $ spawn $ "systemctl --user start mbsync.service" @@ -266,7 +266,7 @@ getCaptureDir = do fallback = ( ".local/share") <$> getHomeDirectory runFlameshot :: String -> String -> SometimesX -runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture) +runFlameshot n mode = sometimesIO_ n "flameshot" (Only_ $ sysExe myCapture) $ spawnCmd myCapture [mode] -- TODO this will steal focus from the current window (and puts it @@ -283,7 +283,7 @@ runScreenCapture :: SometimesX runScreenCapture = runFlameshot "screen capture" "screen" runCaptureBrowser :: SometimesX -runCaptureBrowser = sometimesIO "screen capture browser" "feh" +runCaptureBrowser = sometimesIO_ "screen capture browser" "feh" (Only_ $ sysExe myImageBrowser) $ do dir <- io getCaptureDir spawnCmd myImageBrowser [dir] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index daf51c4..34e7a38 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -12,8 +12,8 @@ module XMonad.Internal.Command.Power , runSuspendPrompt , runQuitPrompt , hasBattery - - + , suspendPrompt + , quitPrompt , powerPrompt ) where @@ -45,11 +45,14 @@ myScreenlock = "screenlock" myOptimusManager :: String myOptimusManager = "optimus-manager" +myPrimeOffload :: String +myPrimeOffload = "prime-offload" + -------------------------------------------------------------------------------- -- | Core commands runScreenLock :: SometimesX -runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock +runScreenLock = sometimesExe "screen locker" "i3lock script" False myScreenlock runPowerOff :: X () runPowerOff = spawn "systemctl poweroff" @@ -64,14 +67,27 @@ runReboot :: X () runReboot = spawn "systemctl reboot" -------------------------------------------------------------------------------- --- | Confirm prompt wrappers +-- | Confirmation prompts + +confirmPrompt' :: String -> X () -> T.FontBuilder -> X () +confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x + +suspendPrompt :: T.FontBuilder -> X () +suspendPrompt = confirmPrompt' "suspend?" runSuspend + +quitPrompt :: T.FontBuilder -> X () +quitPrompt = confirmPrompt' "quit?" $ io exitSuccess + +sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX +sometimesPrompt n = sometimesIO n (n ++ " command") + $ Only $ IOAlways T.defFont id -- TODO doesn't this need to also lock the screen? -runSuspendPrompt :: X () -runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend +runSuspendPrompt :: SometimesX +runSuspendPrompt = sometimesPrompt "suspend prompt" suspendPrompt -runQuitPrompt :: X () -runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess +runQuitPrompt :: SometimesX +runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt -------------------------------------------------------------------------------- -- | Nvidia Optimus @@ -91,21 +107,25 @@ hasBattery = do readType p = fromRight [] <$> tryIOError (readFile $ syspath p "type") syspath = "/sys/class/power_supply" -runOptimusPrompt' :: X () -runOptimusPrompt' = do +runOptimusPrompt' :: T.FontBuilder -> X () +runOptimusPrompt' fb = do nvidiaOn <- io isUsingNvidia switch $ if nvidiaOn then "integrated" else "nvidia" where - switch mode = confirmPrompt T.promptTheme (prompt mode) (cmd mode) + switch mode = confirmPrompt' (prompt mode) (cmd mode) fb prompt mode = "gpu switch to " ++ mode ++ "?" cmd mode = spawn $ - "prime-offload" + myPrimeOffload #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"] #!&& "killall xmonad" runOptimusPrompt :: SometimesX -runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager" - (Only_ $ localExe myOptimusManager) runOptimusPrompt' +runOptimusPrompt = Sometimes "graphics switcher" [s] + where + s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error } + r = IORoot runOptimusPrompt' t + t = And1 (Only $ IOAlways T.defFont id) + $ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload) -------------------------------------------------------------------------------- -- | Universal power prompt @@ -134,18 +154,21 @@ instance XPrompt PowerPrompt where showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" runPowerPrompt :: AlwaysX -runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock +runPowerPrompt = Always "power prompt" $ Option sf fallback where - withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id) + sf = Subfeature withLock "lock-enabled prompt" Error + withLock = IORoot (uncurry powerPrompt) tree + tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id) + fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont -powerPromptNoLock :: X () +powerPromptNoLock :: T.FontBuilder -> X () powerPromptNoLock = powerPrompt skip -powerPrompt :: X () -> X () -powerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction +powerPrompt :: X () -> T.FontBuilder -> X () +powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction where comp = mkComplFunFromList theme [] - theme = T.promptTheme { promptKeymap = keymap } + theme = (T.promptTheme fb) { promptKeymap = keymap } keymap = M.fromList $ ((controlMask, xK_g), quit) : map (first $ (,) 0) diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index b3de6c2..f7afce7 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -27,6 +27,7 @@ import XMonad.Internal.Command.Power import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Dependency import XMonad.Internal.Shell +import XMonad.Internal.Theme (FontBuilder, defFont) -------------------------------------------------------------------------------- -- | Data structure to hold the ACPI events I care about @@ -90,17 +91,17 @@ listenACPI = do acpiPath :: FilePath acpiPath = "/var/run/acpid.socket" -socketDep :: Tree_ IODependency_ +socketDep :: IOTree_ socketDep = Only_ $ pathR acpiPath -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) -handleACPI :: X () -> String -> X () -handleACPI lock tag = do +handleACPI :: FontBuilder -> X () -> String -> X () +handleACPI fb lock tag = do let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent forM_ acpiTag $ \case - Power -> powerPrompt lock - Sleep -> runSuspendPrompt + Power -> powerPrompt lock fb + Sleep -> suspendPrompt fb LidClose -> do status <- io isDischarging -- only run suspend if battery exists and is discharging @@ -113,9 +114,12 @@ handleACPI lock tag = do -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them runPowermon :: SometimesIO -runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI +runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI runHandleACPI :: Always (String -> X ()) -runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip +runHandleACPI = Always "ACPI event handler" $ Option sf fallback where - withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id) + sf = Subfeature withLock "acpid prompt" Error + withLock = IORoot (uncurry handleACPI) + $ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id) + fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 6fa536b..c1c217e 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -29,6 +29,10 @@ module XMonad.Internal.Dependency , Root(..) , Tree(..) , Tree_(..) + , IOTree + , IOTree_ + , DBusTree + , DBusTree_ , IODependency(..) , IODependency_(..) , SystemDependency(..) @@ -61,6 +65,7 @@ module XMonad.Internal.Dependency , always1 , sometimes1 , sometimesIO + , sometimesIO_ , sometimesDBus , sometimesExe , sometimesExeArgs @@ -69,6 +74,7 @@ module XMonad.Internal.Dependency -- dependency construction , sysExe , localExe + , fontFam , sysdSystem , sysdUser , listToAnds @@ -187,12 +193,14 @@ type Feature a = Either (Sometimes a) (Always a) data Always a = Always String (Always_ a) -- | Feature that is guaranteed to work (inner data) -data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) +data Always_ a = Option (SubfeatureRoot a) (Always_ a) + | Always_ (FallbackRoot a) -- | Root of a fallback action for an always -- This may either be a lone action or a function that depends on the results -- from other Always features. -data FallbackRoot a = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) +data FallbackRoot a = FallbackAlone a + | forall p. FallbackTree (p -> a) (FallbackStack p) -- | Always features that are used as a payload for a fallback action data FallbackStack p = FallbackBottom (Always p) @@ -225,13 +233,12 @@ data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord) -- | An action and its dependencies -- May be a plain old monad or be DBus-dependent, in which case a client is -- needed -data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p) - | IORoot_ a (Tree_ IODependency_) - | forall p. DBusRoot (p -> Client -> a) - (Tree IODependency DBusDependency_ p) (Maybe Client) - | DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client) +data Root a = forall p. IORoot (p -> a) (IOTree p) + | IORoot_ a IOTree_ + | forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client) + | DBusRoot_ (Client -> a) DBusTree_ (Maybe Client) --- | The dependency tree with rules to merge results +-- | The dependency tree with rule to merge results when needed data Tree d d_ p = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) | And1 (Tree d d_ p) (Tree_ d_) @@ -240,10 +247,13 @@ data Tree d d_ p = | Only (d p) -- | A dependency tree without functions to merge results -data Tree_ d = - And_ (Tree_ d) (Tree_ d) - | Or_ (Tree_ d) (Tree_ d) - | Only_ d +data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d + +-- | Shorthand tree types for lazy typers +type IOTree p = Tree IODependency IODependency_ p +type DBusTree p = Tree IODependency DBusDependency_ p +type IOTree_ = Tree_ IODependency_ +type DBusTree_ = Tree_ DBusDependency_ -- | A dependency that only requires IO to evaluate data IODependency p = IORead String (IO (Result p)) @@ -260,6 +270,7 @@ data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a) data SystemDependency = Executable Bool FilePath + | FontFamily String | AccessiblePath FilePath Bool Bool | IOTest String (IO (Maybe String)) | Systemd UnitType String @@ -434,12 +445,13 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) where msg = unwords [e, "executable", singleQuote bin, "not found"] e = if sys then "system" else "local" -testSysDependency (Systemd t n) = do - (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" - return $ case rc of - ExitSuccess -> Nothing - _ -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found" +testSysDependency (FontFamily fam) = shellTest cmd msg where + msg = unwords ["font family", singleQuote fam, "not found"] + cmd = fmtCmd "fc-list" ["-q", singleQuote fam] +testSysDependency (Systemd t n) = shellTest cmd msg + where + msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n] testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p where @@ -455,6 +467,13 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p _ -> Nothing +shellTest :: String -> String -> IO (Maybe String) +shellTest cmd msg = do + (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" + return $ case rc of + ExitSuccess -> Nothing + _ -> Just msg + unitType :: UnitType -> String unitType SystemUnit = "system" unitType UserUnit = "user" @@ -560,8 +579,11 @@ sometimes1 = sometimes1_ Error always1 :: String -> String -> Root a -> a -> Always a always1 = always1_ Error -sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a -sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t +sometimesIO_ :: String -> String -> IOTree_ -> a -> Sometimes a +sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t + +sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a +sometimesIO fn n t x = sometimes1 fn n $ IORoot x t sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ()) sometimesExe fn n sys path = sometimesExeArgs fn n sys path [] @@ -569,7 +591,7 @@ sometimesExe fn n sys path = sometimesExeArgs fn n sys path [] sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath -> [String] -> Sometimes (m ()) sometimesExeArgs fn n sys path args = - sometimesIO fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args + sometimesIO_ fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_ -> (Client -> a) -> Sometimes a @@ -598,6 +620,9 @@ toAnd a b = And_ (Only_ a) (Only_ b) exe :: Bool -> String -> IODependency_ exe b = IOSystem_ . Executable b +fontFam :: String -> IODependency_ +fontFam = IOSystem_ . FontFamily + sysExe :: String -> IODependency_ sysExe = exe True @@ -723,11 +748,11 @@ dataTree_ f_ = go go (Only_ d) = uncurry jsonLeafUntested $ f_ d dataIODependency :: IODependency p -> DependencyData -dataIODependency d = case d of - (IORead n _) -> (Q "ioread", [("desc", JSON_Q $ Q n)]) +dataIODependency d = first Q $ case d of + (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) -- TODO make this actually useful (I actually need to name my features) - (IOSometimes _ _) -> (Q "sometimes", []) - (IOAlways _ _) -> (Q "always", []) + (IOSometimes _ _) -> ("sometimes", []) + (IOAlways _ _) -> ("always", []) dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of @@ -735,18 +760,19 @@ dataIODependency_ d = case d of (IOSometimes_ _) -> (Q "sometimes", []) dataSysDependency :: SystemDependency -> DependencyData -dataSysDependency d = do +dataSysDependency d = first Q $ case d of - (Executable sys path) -> (Q "executable", [ ("system", JSON_UQ $ jsonBool sys) + (Executable sys path) -> ("executable", [ ("system", JSON_UQ $ jsonBool sys) , ("path", JSON_Q $ Q path) ]) - (IOTest desc _) -> (Q "iotest", [("desc", JSON_Q $ Q desc)]) - (AccessiblePath p r w) -> (Q "path", [ ("path", JSON_Q $ Q p) - , ("readable", JSON_UQ $ jsonBool r) - , ("writable", JSON_UQ $ jsonBool w) - ]) - (Systemd t n) -> (Q "systemd", [ ("unittype", JSON_Q $ Q $ unitType t) - , ("unit", JSON_Q $ Q n)]) + (IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)]) + (FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)]) + (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p) + , ("readable", JSON_UQ $ jsonBool r) + , ("writable", JSON_UQ $ jsonBool w) + ]) + (Systemd t n) -> ("systemd", [ ("unittype", JSON_Q $ Q $ unitType t) + , ("unit", JSON_Q $ Q n)]) dataDBusDependency :: DBusDependency_ -> DependencyData dataDBusDependency d = diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index 52c47ef..7d21b38 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -18,9 +18,12 @@ module XMonad.Internal.Theme , darken' , Slant(..) , Weight(..) - , ThemeFont(..) - , fmtFontXFT - , font + , FontData(..) + , FontBuilder + , buildFont + , defFontData + , defFont + , fontFeature , tabbedTheme , promptTheme ) where @@ -30,8 +33,9 @@ import Data.Colour import Data.Colour.SRGB import Data.List -import qualified XMonad.Layout.Decoration as D -import qualified XMonad.Prompt as P +import XMonad.Internal.Dependency +import qualified XMonad.Layout.Decoration as D +import qualified XMonad.Prompt as P -------------------------------------------------------------------------------- -- | Colors - vocabulary roughly based on GTK themes @@ -96,24 +100,25 @@ data Weight = Light | Black deriving (Eq, Show) -data ThemeFont = ThemeFont - { family :: String - , weight :: Maybe Weight +data FontData = FontData + { weight :: Maybe Weight , slant :: Maybe Slant , size :: Maybe Int , pixelsize :: Maybe Int , antialias :: Maybe Bool } -fmtFontXFT :: ThemeFont -> String -fmtFontXFT ThemeFont - { family = f - , weight = w - , slant = l - , size = s - , pixelsize = p - , antialias = a - } = intercalate ":" $ ["xft", f] ++ elems +type FontBuilder = FontData -> String + +buildFont :: Maybe String -> FontData -> String +buildFont Nothing _ = "fixed" +buildFont (Just fam) FontData { weight = w + , slant = l + , size = s + , pixelsize = p + , antialias = a + } + = intercalate ":" $ ["xft", fam] ++ elems where elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w) , ("slant", showLower l) @@ -125,22 +130,34 @@ fmtFontXFT ThemeFont showLower :: Show a => Maybe a -> Maybe String showLower = fmap (fmap toLower . show) -font :: ThemeFont -font = ThemeFont - { family = "DejaVu Sans" - , size = Just 10 +fontFeature :: String -> String -> Always FontBuilder +fontFeature n fam = always1 n sfn root def + where + sfn = "Font family for " ++ fam + root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam + def = buildFont Nothing + +-------------------------------------------------------------------------------- +-- | Default font and data + +defFontData :: FontData +defFontData = FontData + { size = Just 10 , antialias = Just True , weight = Nothing , slant = Nothing , pixelsize = Nothing } +defFont :: Always FontBuilder +defFont = fontFeature "Default Font" "DejaVu Sans" + -------------------------------------------------------------------------------- -- | Complete themes -tabbedTheme :: D.Theme -tabbedTheme = D.def - { D.fontName = fmtFontXFT font { weight = Just Bold } +tabbedTheme :: FontBuilder -> D.Theme +tabbedTheme fb = D.def + { D.fontName = fb $ defFontData { weight = Just Bold } , D.activeTextColor = fgColor , D.activeColor = bgColor @@ -162,11 +179,11 @@ tabbedTheme = D.def , D.decoHeight = 20 , D.windowTitleAddons = [] , D.windowTitleIcons = [] -} + } -promptTheme :: P.XPConfig -promptTheme = P.def - { P.font = fmtFontXFT font { size = Just 12 } +promptTheme :: FontBuilder -> P.XPConfig +promptTheme fb = P.def + { P.font = fb $ defFontData { size = Just 12 } , P.bgColor = bgColor , P.fgColor = fgColor , P.fgHLight = selectedFgColor