From f6b35d4109d49002538965640abf3629aa8337f5 Mon Sep 17 00:00:00 2001 From: weiss Date: Sun, 21 Jan 2024 12:10:52 +0100 Subject: [PATCH] migrate old xmonad config --- devshell.toml | 7 + flake.lock | 73 +++++++++- flake.nix | 65 +++++---- fourmolu.yaml | 8 ++ src/Lib.hs | 7 - src/MyLogger.hs | 71 ++++++++++ src/MyNamedScratchpad.hs | 233 ++++++++++++++++++++++++++++++++ src/MyPromptPass.hs | 173 ++++++++++++++++++++++++ src/MyWindowOperations.hs | 158 ++++++++++++++++++++++ src/MyWorkspace.hs | 66 +++++++++ src/MyWorkspaces.hs | 11 ++ src/MyXMonad.hs | 273 ++++++++++++++++++++++++++++++++++++++ src/MyXmobar.hs | 103 ++++++++++++++ weiss-xmonad.cabal | 83 ++++++++++-- 14 files changed, 1288 insertions(+), 43 deletions(-) create mode 100644 devshell.toml create mode 100755 fourmolu.yaml delete mode 100644 src/Lib.hs create mode 100644 src/MyLogger.hs create mode 100644 src/MyNamedScratchpad.hs create mode 100644 src/MyPromptPass.hs create mode 100644 src/MyWindowOperations.hs create mode 100644 src/MyWorkspace.hs create mode 100644 src/MyWorkspaces.hs create mode 100644 src/MyXMonad.hs create mode 100644 src/MyXmobar.hs diff --git a/devshell.toml b/devshell.toml new file mode 100644 index 0000000..8bd2903 --- /dev/null +++ b/devshell.toml @@ -0,0 +1,7 @@ +[[commands]] +name = "doc" +command = ''' +echo http://127.0.0.1:9898 +hoogle serve -p 9898 --local + ''' +help = "run hoogle server locally for documentation" diff --git a/flake.lock b/flake.lock index a0d255d..315031e 100644 --- a/flake.lock +++ b/flake.lock @@ -1,6 +1,43 @@ { "nodes": { + "devshell": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + }, + "locked": { + "lastModified": 1705332421, + "narHash": "sha256-USpGLPme1IuqG78JNqSaRabilwkCyHmVWY0M9vYyqEA=", + "owner": "numtide", + "repo": "devshell", + "rev": "83cb93d6d063ad290beee669f4badf9914cc16ec", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "devshell", + "type": "github" + } + }, "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1701680307, + "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_2": { "locked": { "lastModified": 1644229661, "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", @@ -16,6 +53,22 @@ } }, "nixpkgs": { + "locked": { + "lastModified": 1704161960, + "narHash": "sha256-QGua89Pmq+FBAro8NriTuoO/wNaUtugt29/qqA8zeeM=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "63143ac2c9186be6d9da6035fa22620018c85932", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { "locked": { "lastModified": 1705543379, "narHash": "sha256-8wC0vVz/LTqJprbAAvE9P4L01Mi6DJHYwvuM0Uq57og=", @@ -33,8 +86,24 @@ }, "root": { "inputs": { - "flake-utils": "flake-utils", - "nixpkgs": "nixpkgs" + "devshell": "devshell", + "flake-utils": "flake-utils_2", + "nixpkgs": "nixpkgs_2" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" } } }, diff --git a/flake.nix b/flake.nix index 3f3e135..c11ae10 100644 --- a/flake.nix +++ b/flake.nix @@ -1,10 +1,13 @@ { description = "weiss-xmonad"; - inputs.nixpkgs.url = "github:NixOS/nixpkgs/release-23.11"; - inputs.flake-utils.url = "github:numtide/flake-utils"; + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs/release-23.11"; + flake-utils.url = "github:numtide/flake-utils"; + devshell.url = "github:numtide/devshell"; + }; - outputs = inputs: + outputs = { self, flake-utils, devshell, nixpkgs, ... }: let overlay = final: prev: { haskell = prev.haskell // { @@ -13,33 +16,49 @@ weiss-xmonad = hfinal.callCabal2nix "weiss-xmonad" ./. { }; }; }; - weiss-xmonad = final.haskell.lib.compose.justStaticExecutables final.haskellPackages.weiss-xmonad; + weiss-xmonad = final.haskell.lib.compose.justStaticExecutables + final.haskellPackages.weiss-xmonad; }; perSystem = system: let - pkgs = import inputs.nixpkgs { inherit system; overlays = [ overlay ]; }; - hspkgs = pkgs.haskellPackages; - in - { - devShells = rec { - default = weiss-xmonad-shell; - weiss-xmonad-shell = hspkgs.shellFor { - withHoogle = true; - packages = p: [ p.weiss-xmonad ]; - buildInputs = [ - hspkgs.cabal-install - hspkgs.haskell-language-server - hspkgs.hlint - hspkgs.ormolu - pkgs.bashInteractive - ]; - }; + pkgs = import nixpkgs { + inherit system; + overlays = [ overlay devshell.overlays.default ]; + }; + ghcVersion = "ghc948"; + hspkgs = pkgs.haskell.packages.${ghcVersion}; + devShells.shellFor = hspkgs.shellFor { + packages = p: [ p.weiss-xmonad ]; + withHoogle = true; + }; + in { + devShells.default = pkgs.devshell.mkShell { + name = "weiss-xmonad"; + imports = [ (pkgs.devshell.importTOML ./devshell.toml) ]; + # packages = [ pkgs.hpack ]; + packagesFrom = [ devShells.shellFor ]; + commands = [ + (let cabal = pkgs.cabal-install; + in { + name = cabal.pname; + help = cabal.meta.description; + package = cabal; + category = "tools"; + }) + (let hls = hspkgs.haskell-language-server; + in { + name = hls.pname; + help = hls.meta.description; + package = hls; + category = "tools"; + }) + ]; + packages = [ hspkgs.hlint hspkgs.fourmolu hspkgs.cabal-fmt ]; }; packages = rec { default = weiss-xmonad; weiss-xmonad = pkgs.weiss-xmonad; }; }; - in - { inherit overlay; } // inputs.flake-utils.lib.eachDefaultSystem perSystem; + in { inherit overlay; } // flake-utils.lib.eachDefaultSystem perSystem; } diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100755 index 0000000..ef5582d --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 2 +comma-style: leading +record-brace-space: true +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: multi-line +newlines-between-decls: 1 \ No newline at end of file diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index 1055c22..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Lib - ( someFunc, - ) -where - -someFunc :: IO () -someFunc = putStrLn "hey" diff --git a/src/MyLogger.hs b/src/MyLogger.hs new file mode 100644 index 0000000..1147656 --- /dev/null +++ b/src/MyLogger.hs @@ -0,0 +1,71 @@ +module MyLogger where + +import Data.List +import Data.Maybe +import Text.Regex +import XMonad +import XMonad.Hooks.StatusBar.PP +import qualified XMonad.StackSet as W +import XMonad.Util.Loggers +import XMonad.Util.NamedWindows + +totalTitlesLength, unfocusedTitleLength :: Int +totalTitlesLength = 90 +unfocusedTitleLength = 30 + +-- receive one sperate and three funs to format count, focused window and unfocused window +myLogTitles + :: String + -> String + -> (Int -> String) + -> (String -> String) + -> ([String] -> String) + -> Logger +myLogTitles sep1 sep2 formatCount formatFoc formatUnfoc = do + winset <- gets windowset + let focWin = W.peek winset + wins = W.index winset + winsUnfoc = filter (\w -> Just w /= focWin) wins + count = length wins + winNamesUnfoc <- case winsUnfoc of + [] -> pure "" + xs -> (sep2 ++) . formatUnfoc <$> traverse (fmap show . getName) xs + focWinName <- case focWin of + Just justFoc -> + (sep1 ++) + . formatFoc + . shorten (totalTitlesLength - (count - 1) * unfocusedTitleLength) + . show + <$> getName justFoc + Nothing -> pure "" + pure . Just $ formatCount count ++ focWinName ++ winNamesUnfoc + + +logWindowCount :: X (Maybe String) +logWindowCount = withWindowSet ct where + ct ss = + return + $ Just + $ show + $ length + $ W.integrate' + $ W.stack + $ W.workspace + $ W.current ss + + +logMaster :: X Bool +logMaster = withWindowSet isMaster where + isMaster ss = return $ case W.stack . W.workspace . W.current $ ss of + Just (W.Stack _ [] _) -> True + _ -> False + +trimPrefixWithList :: [String] -> Maybe String -> Maybe String +trimPrefixWithList _ Nothing = Nothing +trimPrefixWithList xs (Just s) = case mapMaybe (`stripPrefix` s) xs of + [] -> Just s + n : _ -> trimPrefixWithList xs (Just n) + +trimLayoutModifiers :: Maybe String -> Maybe String +trimLayoutModifiers = trimPrefixWithList ["Spacing", " "] + diff --git a/src/MyNamedScratchpad.hs b/src/MyNamedScratchpad.hs new file mode 100644 index 0000000..c598734 --- /dev/null +++ b/src/MyNamedScratchpad.hs @@ -0,0 +1,233 @@ +module MyNamedScratchpad where + +import XMonad +import XMonad.Actions.SpawnOn ( spawnHere ) +import XMonad.Hooks.DynamicLog ( PP + , ppSort + ) +import XMonad.Hooks.ManageHelpers ( doRectFloat ) +import XMonad.Hooks.RefocusLast ( withRecentsIn ) +import XMonad.Prelude ( filterM + , find + , unless + , when + ) + +import qualified Data.List.NonEmpty as NE + +import Control.Concurrent +import Control.Monad +import qualified Data.Map as M +import Data.Maybe +import MyWindowOperations +import System.Timeout +import qualified XMonad.StackSet as W + +-- | Single named scratchpad configuration +data NamedScratchpad = NS + { name :: String -- ^ Scratchpad name + , cmd :: String -- ^ Command used to run application + , query :: Query Bool -- ^ Query to find already running application + , after :: Window -> X () -- ^ this function will be called after the scratchpad is shifted to the current workspace + } + +-- | Named scratchpads configuration +type NamedScratchpads = [NamedScratchpad] + +existsNsp :: NamedScratchpads -> X Bool +existsNsp nsp = withWindowSet $ \winSet -> isJust <$> findNspFromWindows + nsp + (W.integrate' (W.stack . W.workspace . W.current $ winSet)) + +focusWithNsp :: X () -> NamedScratchpads -> X () +focusWithNsp f scratchpads = withFocused $ \win -> do + mShiftedScratchpads <- shiftBackAllNspFromCurrentWsp scratchpads + case mShiftedScratchpads of + [] -> f + shiftedScratchpads -> do + f + withFocused $ \focused -> do + shiftHereAllNsp shiftedScratchpads + focus focused + +myFocusDownWithNSP :: NamedScratchpads -> X () +myFocusDownWithNSP = focusWithNsp myFocusDownPure + +myFocusUpWithNSP :: NamedScratchpads -> X () +myFocusUpWithNSP = focusWithNsp myFocusUpPure + +mySwapMasterWithNsp :: NamedScratchpads -> X () +mySwapMasterWithNsp scratchpads = withFocused $ \win -> do + mShiftedScratchpads <- shiftBackAllNspFromCurrentWsp scratchpads + case mShiftedScratchpads of + [] -> mySwapMasterPure + shiftedScratchpads -> withFocused $ \focused -> do + shiftHereAllNsp shiftedScratchpads + focus focused + +findNsp :: NamedScratchpads -> Window -> X (Maybe NamedScratchpad) +findNsp [] a = return Nothing +findNsp (x : xs) a = do + fromNsp <- runQuery (query x) a + if fromNsp then return (Just x) else findNsp xs a + +findNspFromWindows :: NamedScratchpads -> [Window] -> X (Maybe NamedScratchpad) +findNspFromWindows _ [] = return Nothing +findNspFromWindows scratchpads (a : as) = do + mNsp <- findNsp scratchpads a + case mNsp of + Nothing -> findNspFromWindows scratchpads as + Just nsp -> return $ Just nsp + +findNspCurrentWsp :: NamedScratchpads -> X (Maybe NamedScratchpad) +findNspCurrentWsp nsp = withWindowSet $ \winSet -> findNspFromWindows nsp + $ W.integrate' (W.stack . W.workspace . W.current $ winSet) + + +-- | Finds named scratchpad configuration by name +findByName :: NamedScratchpads -> String -> Maybe NamedScratchpad +findByName c s = find ((s ==) . name) c + +-- | Runs application which should appear in specified scratchpad +runApplication :: NamedScratchpad -> X () +runApplication = spawn . cmd + +-- | Runs application which should appear in a specified scratchpad on the workspace it was launched on +runApplicationHere :: NamedScratchpad -> X () +runApplicationHere = spawnHere . cmd + +-- | Action to pop up specified named scratchpad +namedScratchpadAction + :: NamedScratchpads -- ^ Named scratchpads configuration + -> String -- ^ Scratchpad name + -> X () +namedScratchpadAction = customRunNamedScratchpadAction runApplication + +-- | Action to pop up specified named scratchpad, initially starting it on the current workspace. +spawnHereNamedScratchpadAction + :: NamedScratchpads -- ^ Named scratchpads configuration + -> String -- ^ Scratchpad name + -> X () +spawnHereNamedScratchpadAction = + customRunNamedScratchpadAction runApplicationHere + +-- | Action to pop up specified named scratchpad, given a custom way to initially start the application. +customRunNamedScratchpadAction + :: (NamedScratchpad -> X ()) -- ^ Function initially running the application, given the configured @scratchpad@ cmd + -> NamedScratchpads -- ^ Named scratchpads configuration + -> String -- ^ Scratchpad name + -> X () +customRunNamedScratchpadAction = + someNamedScratchpadAction (\f ws -> f $ NE.head ws) + +allNamedScratchpadAction :: NamedScratchpads -> String -> X () +allNamedScratchpadAction = someNamedScratchpadAction mapM_ runApplication + +-- | execute some action on a named scratchpad +someNamedScratchpadAction + :: ((Window -> X ()) -> NE.NonEmpty Window -> X ()) + -> (NamedScratchpad -> X ()) + -> NamedScratchpads + -> String + -> X () +someNamedScratchpadAction f runApp scratchpadConfig scratchpadName = + case findByName scratchpadConfig scratchpadName of + Just conf -> withWindowSet $ \winSet -> do + matchingOnAll <- filterM (runQuery (query conf)) + (W.allWindows winSet) + let nonMatchedOnCurrent = case NE.nonEmpty matchingOnAll of + Nothing -> do + runApp conf + -- waitRun 10000 conf + Just wins -> do + f (windows . W.shiftWin (W.currentTag winSet)) wins + after conf (NE.head wins) + case W.stack . W.workspace . W.current $ winSet of + Nothing -> nonMatchedOnCurrent + Just curStk -> do + isFocused <- runQuery (query conf) (W.focus curStk) + matchingOnCurrent <- filterM (runQuery (query conf)) + (W.integrate curStk) + case NE.nonEmpty matchingOnCurrent of + Nothing -> nonMatchedOnCurrent + Just wins -> if isFocused + then shiftBack (W.focus curStk) + else focus (NE.head wins) + + Nothing -> return () + where + waitRun :: Int -> NamedScratchpad -> X () + waitRun limit conf = if limit <= 0 + then return () + else withWindowSet $ \winSet -> do + refresh + matchingOnAll <- filterM (runQuery (query conf)) + (W.allWindows winSet) + case NE.nonEmpty matchingOnAll of + Nothing -> waitRun (limit - 1) conf + Just wins -> do + windows $ W.focusWindow (NE.head wins) + after conf (NE.head wins) + +-- | Tag of the scratchpad workspace +scratchpadWorkspaceTag :: String +scratchpadWorkspaceTag = "板" + +shiftBack :: Window -> X () +shiftBack a = windows $ W.shiftWin scratchpadWorkspaceTag a + +shiftBackAllNsp :: NamedScratchpads -> [Window] -> X NamedScratchpads +shiftBackAllNsp _ [] = return [] +shiftBackAllNsp scratchpads (a : as) = do + mScratchpad <- findNsp scratchpads a + case mScratchpad of + Nothing -> shiftBackAllNsp scratchpads as + Just scratchpad -> + shiftBack a >> fmap (scratchpad :) (shiftBackAllNsp scratchpads as) + +shiftBackAllNspFromCurrentWsp :: NamedScratchpads -> X NamedScratchpads +shiftBackAllNspFromCurrentWsp scratchpads = withWindowSet $ \winSet -> + shiftBackAllNsp + scratchpads + (W.integrate' (W.stack . W.workspace . W.current $ winSet)) + + +shiftHereAllNsp :: NamedScratchpads -> X () +shiftHereAllNsp scratchpads = foldr + (\elem res -> namedScratchpadAction scratchpads $ name elem) + (return ()) + scratchpads + +-- | Shift some windows to the scratchpad workspace according to the +-- given function. The workspace is created if necessary. +-- shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X () +-- shiftToNSP ws f = do +-- unless (any ((scratchpadWorkspaceTag ==) . W.tag) ws) +-- $ addHiddenWorkspace scratchpadWorkspaceTag +-- f (windows . W.shiftWin scratchpadWorkspaceTag) + +-- | Transforms a workspace list containing the NSP workspace into one that +-- doesn't contain it. Intended for use with logHooks. +namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace] +namedScratchpadFilterOutWorkspace = + filter (\(W.Workspace tag _ _) -> tag /= scratchpadWorkspaceTag) +{-# DEPRECATED namedScratchpadFilterOutWorkspace "Use XMonad.Util.WorkspaceCompare.filterOutWs [scratchpadWorkspaceTag] instead" #-} + +-- | Transforms a pretty-printer into one not displaying the NSP workspace. +-- +-- A simple use could be: +-- +-- > logHook = dynamicLogWithPP . namedScratchpadFilterOutWorkspace $ def +-- +-- Here is another example, when using "XMonad.Layout.IndependentScreens". +-- If you have handles @hLeft@ and @hRight@ for bars on the left and right screens, respectively, and @pp@ is a pretty-printer function that takes a handle, you could write +-- +-- > logHook = let log screen handle = dynamicLogWithPP . namedScratchpadFilterOutWorkspacePP . marshallPP screen . pp $ handle +-- > in log 0 hLeft >> log 1 hRight +namedScratchpadFilterOutWorkspacePP :: PP -> PP +namedScratchpadFilterOutWorkspacePP pp = + pp { ppSort = fmap (. namedScratchpadFilterOutWorkspace) (ppSort pp) } +{-# DEPRECATED namedScratchpadFilterOutWorkspacePP "Use XMonad.Hooks.DynamicLog.filterOutWsPP [scratchpadWorkspaceTag] instead" #-} +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} + +-- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: diff --git a/src/MyPromptPass.hs b/src/MyPromptPass.hs new file mode 100644 index 0000000..59c67ed --- /dev/null +++ b/src/MyPromptPass.hs @@ -0,0 +1,173 @@ +module MyPromptPass where + +import System.Directory (getHomeDirectory) +import System.FilePath (combine, dropExtension, takeExtension) +import System.Posix.Env (getEnv) +import XMonad.Core +import XMonad.Prompt + ( XPConfig, + XPrompt, + commandToComplete, + getNextCompletion, + mkXPrompt, + nextCompletion, + searchPredicate, + showXPrompt, + ) +import XMonad.Util.Run (runProcessWithInput) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Prompt.Pass +-- +-- Then add a keybinding for 'passPrompt', 'passGeneratePrompt', +-- 'passRemovePrompt', 'passEditPrompt' or 'passTypePrompt': +-- +-- > , ((modMask , xK_p) , passPrompt xpconfig) +-- > , ((modMask .|. controlMask, xK_p) , passGeneratePrompt xpconfig) +-- > , ((modMask .|. shiftMask, xK_p) , passEditPrompt xpconfig) +-- > , ((modMask .|. controlMask .|. shiftMask, xK_p), passRemovePrompt xpconfig) +-- +-- For detailed instructions on: +-- +-- - editing your key bindings, see "XMonad.Doc.Extending#Editing_key_bindings". +-- +-- - how to setup the password store, see + +type Predicate = String -> String -> Bool + +getPassCompl :: [String] -> Predicate -> String -> IO [String] +getPassCompl compls p s = return $ filter (p s) compls + +type PromptLabel = String + +newtype Pass = Pass PromptLabel + +instance XPrompt Pass where + showXPrompt (Pass prompt) = prompt ++ ": " + commandToComplete _ c = c + nextCompletion _ = getNextCompletion + +-- | Default password store folder in $HOME/.password-store +passwordStoreFolderDefault :: String -> String +passwordStoreFolderDefault home = combine home ".password-store" + +-- | Compute the password store's location. +-- Use the PASSWORD_STORE_DIR environment variable to set the password store. +-- If empty, return the password store located in user's home. +passwordStoreFolder :: IO String +passwordStoreFolder = + getEnv "PASSWORD_STORE_DIR" >>= computePasswordStoreDir + where + computePasswordStoreDir Nothing = fmap passwordStoreFolderDefault getHomeDirectory + computePasswordStoreDir (Just storeDir) = return storeDir + +-- | A pass prompt factory +mkPassPrompt :: PromptLabel -> (String -> X ()) -> XPConfig -> X () +mkPassPrompt promptLabel passwordFunction xpconfig = do + passwords <- io (passwordStoreFolder >>= getPasswords) + mkXPrompt (Pass promptLabel) xpconfig (getPassCompl passwords $ searchPredicate xpconfig) passwordFunction + +sendToClj :: String -> X () +sendToClj s = spawn $ "bb /home/weiss/scripts/passInput.clj " ++ s + +-- | A prompt to retrieve a password from a given entry. +passPrompt :: XPConfig -> X () +passPrompt = mkPassPrompt "Select password" selectPassword + +-- | A prompt to retrieve a OTP from a given entry. +passOTPPrompt :: XPConfig -> X () +passOTPPrompt = mkPassPrompt "Select OTP" selectOTP + +-- | A prompt to generate a password for a given entry. +-- This can be used to override an already stored entry. +-- (Beware that no confirmation is asked) +passGeneratePrompt :: XPConfig -> X () +passGeneratePrompt = mkPassPrompt "Generate password" generatePassword + +-- | A prompt to generate a password for a given entry and immediately copy it +-- to the clipboard. This can be used to override an already stored entry. +-- (Beware that no confirmation is asked) +passGenerateAndCopyPrompt :: XPConfig -> X () +passGenerateAndCopyPrompt = mkPassPrompt "Generate and copy password" generateAndCopyPassword + +-- | A prompt to remove a password for a given entry. +-- (Beware that no confirmation is asked) +passRemovePrompt :: XPConfig -> X () +passRemovePrompt = mkPassPrompt "Remove password" removePassword + +-- | A prompt to type in a password for a given entry. +-- This doesn't touch the clipboard. +passTypePrompt :: XPConfig -> X () +passTypePrompt = mkPassPrompt "Type password" typePassword + +-- | A prompt to edit a given entry. +-- This doesn't touch the clipboard. +passEditPrompt :: XPConfig -> X () +passEditPrompt = mkPassPrompt "Edit password" editPassword + +-- | Select a password. +selectPassword :: String -> X () +selectPassword passLabel = spawn $ "pass --clip \"" ++ escapeQuote passLabel ++ "\"" + +-- | Select a OTP. +selectOTP :: String -> X () +selectOTP passLabel = spawn $ "pass otp --clip \"" ++ escapeQuote passLabel ++ "\"" + +-- | Generate a 30 characters password for a given entry. +-- If the entry already exists, it is updated with a new password. +generatePassword :: String -> X () +generatePassword passLabel = spawn $ "pass generate --force \"" ++ escapeQuote passLabel ++ "\" 30" + +-- | Generate a 30 characters password for a given entry. +-- If the entry already exists, it is updated with a new password. +-- After generating the password, it is copied to the clipboard. +generateAndCopyPassword :: String -> X () +generateAndCopyPassword passLabel = spawn $ "pass generate --force -c \"" ++ escapeQuote passLabel ++ "\" 30" + +-- | Remove a password stored for a given entry. +removePassword :: String -> X () +removePassword passLabel = spawn $ "pass rm --force \"" ++ escapeQuote passLabel ++ "\"" + +-- | Edit a password stored for a given entry. +editPassword :: String -> X () +editPassword passLabel = spawn $ "pass edit \"" ++ escapeQuote passLabel ++ "\"" + +-- | Type a password stored for a given entry using xdotool. +typePassword :: String -> X () +typePassword passLabel = + spawn $ + "pass \"" + ++ escapeQuote passLabel + ++ "\"|head -n1|tr -d '\n'|xdotool type --clearmodifiers --file -" + +escapeQuote :: String -> String +escapeQuote = concatMap escape + where + escape :: Char -> String + escape '"' = ['\\', '\"'] + escape x = return x + +-- | Retrieve the list of passwords from the password store 'passwordStoreDir +getPasswords :: FilePath -> IO [String] +getPasswords passwordStoreDir = do + files <- + runProcessWithInput + "find" + [ "-L", -- Traverse symlinks + passwordStoreDir, + "-type", + "f", + "-name", + "*.gpg", + "-printf", + "%P\n" + ] + [] + return . map removeGpgExtension $ lines files + +removeGpgExtension :: String -> String +removeGpgExtension file + | takeExtension file == ".gpg" = dropExtension file + | otherwise = file diff --git a/src/MyWindowOperations.hs b/src/MyWindowOperations.hs new file mode 100644 index 0000000..5cc35a9 --- /dev/null +++ b/src/MyWindowOperations.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE LambdaCase #-} + +module MyWindowOperations where +import Data.List.Unique +import qualified Data.Map as M +import qualified Data.Map +import Data.Maybe +import MyLogger +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Util.Loggers + +isMaster :: W.StackSet i l a s sd -> Bool +isMaster ss = case W.stack . W.workspace . W.current $ ss of + Just (W.Stack _ [] _) -> True + _ -> False + +isFloating :: Window -> X Bool +isFloating w = do + ws <- gets windowset + return $ M.member w (W.floating ws) + +existsFloating :: X Bool +existsFloating = withWindowSet $ \winSet -> do + let windows = W.integrate' (W.stack . W.workspace . W.current $ winSet) + allFloatings = W.floating winSet + return $ not $ allUnique $ windows ++ M.keys allFloatings + +myFocusDownPure :: X () +myFocusDownPure = + focusWithFloating (windows (`skipFloating` W.focusDown)) myFocusDownPure' + +myFocusUpPure :: X () +myFocusUpPure = + focusWithFloating (windows (`skipFloating` W.focusUp)) myFocusUpPure' + +focusWithFloating :: X () -> X () -> X () +focusWithFloating withFloating withoutFloating = do + floatP <- existsFloating + if floatP then withFloating else withoutFloating + +myFocusDownPure' :: X () +myFocusDownPure' = do + l <- logLayout + case trimLayoutModifiers l of + Just "TwoPane" -> windows focusDownTwoPane + Just "Mirror Tall" -> windows $ skipMaster W.focusUp + Just "Tall" -> windows $ skipMaster W.focusDown + _ -> windows W.focusDown + where + focusDownTwoPane :: W.StackSet i l a s sd -> W.StackSet i l a s sd + focusDownTwoPane = W.modify' $ \stack -> case stack of + W.Stack r1 (l : up) (r2 : down) -> W.Stack r2 [l] (r1 : up ++ down) + W.Stack l [] (r1 : r2 : down) -> W.Stack r1 [l] (r2 : down) + _ -> W.focusDown' stack + skipMaster :: (W.StackSet i l a s sd -> W.StackSet i l a s sd) -> W.StackSet i l a s sd -> W.StackSet i l a s sd + skipMaster f x = if isMaster x + then f x + else + let newS = f x + in if isMaster newS then f newS else newS + +myFocusUpPure' :: X () +myFocusUpPure' = do + l <- logLayout + case trimLayoutModifiers l of + Just "TwoPane" -> windows focusUpTwoPane + Just "Mirror Tall" -> windows $ backToMaster W.focusDown + Just "Tall" -> windows $ backToMaster W.focusUp + _ -> windows W.focusUp + where + focusUpTwoPane :: W.StackSet i l a s sd -> W.StackSet i l a s sd + focusUpTwoPane = W.modify' $ \stack -> case stack of + -- W.Stack r2 (l : r1 : up) down -> W.Stack l [] (r2 : r1 : down) + W.Stack r1 (l : up) (r2 : down) -> W.Stack l [] (r1 : r2 : down) + W.Stack l [] (r1 : r2 : down) -> W.Stack r2 [l] (r1 : down) + _ -> W.focusUp' stack + backToMaster :: (W.StackSet i l a s sd -> W.StackSet i l a s sd) -> W.StackSet i l a s sd -> W.StackSet i l a s sd + backToMaster f x = if isMaster x then f x else W.focusMaster x + +mySwapMasterPure :: X () +mySwapMasterPure = do + l <- logLayout + case trimLayoutModifiers l of + Just "TwoPane" -> windows swapMasterTwoPane + _ -> windows $ W.modify' swapBetweenMasterAndSlave + where + swapBetweenMasterAndSlave :: W.Stack a -> W.Stack a + swapBetweenMasterAndSlave stack = case stack of + W.Stack f [] [] -> stack + W.Stack f [] ds -> W.Stack (last ds) [] (f : init ds) + W.Stack t ls rs -> W.Stack t [] (xs ++ x : rs) + where (x : xs) = reverse ls + swapMasterTwoPane :: W.StackSet i l a s sd -> W.StackSet i l a s sd + swapMasterTwoPane = W.modify' $ \stack -> case stack of + W.Stack r2 (l : r1 : up) down -> W.Stack r1 [r2] (l : down) + W.Stack r1 (l : up) (r2 : down) -> W.Stack r2 [r1] (l : down) + W.Stack l [] (r1 : r2 : down) -> W.Stack l [] (r2 : r1 : down) + _ -> swapBetweenMasterAndSlave stack + + + + +-- | if the workspace is visible in some screen, then focus to this screen, else switch current screen to that workspace +switchOrFocus :: WorkspaceId -> X () +switchOrFocus ws = switchOrFocusHelp ws 0 + where + switchOrFocusHelp ws sc = screenWorkspace sc >>= \case + Nothing -> windows $ W.greedyView ws + Just x -> if x == ws + then windows $ W.view x + else switchOrFocusHelp ws (sc + 1) + +-- from https://www.reddit.com/r/xmonad/comments/hm2tg0/how_to_toggle_floating_state_on_a_window/ +toggleFloat :: Window -> X () +toggleFloat w = windows + (\s -> if M.member w (W.floating s) + then W.sink w s + else W.float w (W.RationalRect 0 0 1 1) s + ) + +shiftThenSwitchOrFocus i = do + windows $ W.shift i + switchOrFocus i + + + +-- comes from https://gist.github.com/gilbertw1/603c3af68a21a10f1833 +skipFloating + :: (Eq a, Ord a) + => W.StackSet i l a s sd + -> (W.StackSet i l a s sd -> W.StackSet i l a s sd) + -> W.StackSet i l a s sd +skipFloating stacks f | isNothing curr = stacks + | -- short circuit if there is no currently focused window + otherwise = skipFloatingR stacks curr f + where curr = W.peek stacks + +skipFloatingR + :: (Eq a, Ord a) + => W.StackSet i l a s sd + -> (Maybe a) + -> (W.StackSet i l a s sd -> W.StackSet i l a s sd) + -> W.StackSet i l a s sd +skipFloatingR stacks startWindow f + | isNothing nextWindow = stacks + | -- next window is nothing return current stack set + nextWindow == startWindow = newStacks + | -- if next window is the starting window then return the new stack set + M.notMember (fromJust nextWindow) (W.floating stacks) = newStacks + | -- if next window is not a floating window return the new stack set + otherwise = skipFloatingR newStacks startWindow f -- the next window is a floating window so keep recursing (looking) + where + newStacks = f stacks + nextWindow = W.peek newStacks + + + diff --git a/src/MyWorkspace.hs b/src/MyWorkspace.hs new file mode 100644 index 0000000..b2a44cf --- /dev/null +++ b/src/MyWorkspace.hs @@ -0,0 +1,66 @@ +module MyWorkspace (myWorkspaces, workspaceKeys) where + +import MyNamedScratchpad +import MyWindowOperations +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS + +newtype RootWorkspace = RootWorkspace {fromRootWorkspace :: Int} deriving (Show) + +-- newtype GeneralWorkspace = GeneralWorkspace Int deriving (Show) +type SubWorkspace = Int + +data Workspace = Id String | SubWorkspace Int deriving (Show) + +instance ExtensionClass RootWorkspace where + initialValue = RootWorkspace 1 + +rootWorkspaces :: [RootWorkspace] +rootWorkspaces = map RootWorkspace [1 .. 9] + +subWorkspaces :: [SubWorkspace] +subWorkspaces = [1 .. 9] + +commonWorkspaces :: [String] +commonWorkspaces = ["览", "邮", "泛", "音", "娱", "聊", scratchpadWorkspaceTag] + +myWorkspaces :: [WorkspaceId] +myWorkspaces = [toWorkspaceId r s | r <- rootWorkspaces, s <- subWorkspaces] ++ commonWorkspaces + +toWorkspaceId :: RootWorkspace -> SubWorkspace -> WorkspaceId +toWorkspaceId (RootWorkspace r) s = show r ++ "." ++ show s + +getWorkspaceId :: SubWorkspace -> X WorkspaceId +getWorkspaceId s = (`toWorkspaceId` s) <$> XS.get + +applyWorkspace :: (WorkspaceId -> X ()) -> Workspace -> X () +applyWorkspace f (SubWorkspace s) = getWorkspaceId s >>= f +applyWorkspace f (Id id) = f id + +switchWorkspace :: Workspace -> X () +switchWorkspace = applyWorkspace (windows . W.greedyView) + +shiftWorkspace :: Workspace -> X () +shiftWorkspace = applyWorkspace (windows . W.shift) + +shiftSwitchWorkspace :: Workspace -> X () +shiftSwitchWorkspace = applyWorkspace shiftThenSwitchOrFocus + +switchRootWorkspace :: RootWorkspace -> X () +switchRootWorkspace r = XS.put r >> switchWorkspace (SubWorkspace 1) + +workspaceKeys :: [(String, X ())] +workspaceKeys = + let subWorkspaceKeys = ["m", ",", ".", "j", "k", "l", "u", "i", "o"] + subWorkspacePairs = zip subWorkspaceKeys (map SubWorkspace subWorkspaces) + commonWorkspacePairs = zip ["", "h", "n", "", "-", "y", "0"] (map Id commonWorkspaces) + in [ (keyPrefix ++ " " ++ k, fun subWorkspace) + | (k, subWorkspace) <- commonWorkspacePairs ++ subWorkspacePairs + , (keyPrefix, fun) <- + [ ("", switchWorkspace) + , (" ", shiftSwitchWorkspace) + , (" ", shiftWorkspace) + ] + ] + ++ zip (map (" " ++) subWorkspaceKeys) (map switchRootWorkspace rootWorkspaces) diff --git a/src/MyWorkspaces.hs b/src/MyWorkspaces.hs new file mode 100644 index 0000000..bf21c7f --- /dev/null +++ b/src/MyWorkspaces.hs @@ -0,0 +1,11 @@ +module MyWorkspaces where + +import MyNamedScratchpad +import MyWindowOperations +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Util.ExtensibleState as XS + +data WithSubWS a = WithSubWS {rootWS :: a, subWS :: Int} deriving (Show) + +data Workspace = FreqWS String | NormalWS (WithSubWS Int) | CommonWS (WithSubWS Int) deriving (Show) diff --git a/src/MyXMonad.hs b/src/MyXMonad.hs new file mode 100644 index 0000000..cc179a2 --- /dev/null +++ b/src/MyXMonad.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +module MyXMonad (runXmonad) where + +import Data.List +import Data.Maybe +import MyLogger +import MyNamedScratchpad +import MyPromptPass +import MyWindowOperations +import MyWorkspace +import MyXmobar +import System.IO (hPutStrLn) +import Text.Regex +import XMonad +import XMonad.Actions.CycleWS +import XMonad.Actions.MouseResize +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.DynamicProperty +import XMonad.Hooks.EwmhDesktops +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Hooks.StatusBar +import XMonad.Layout.Accordion +import XMonad.Layout.LayoutModifier +import XMonad.Layout.MultiColumns +import XMonad.Layout.NoBorders +import XMonad.Layout.NoFrillsDecoration +import XMonad.Layout.PerScreen (ifWider) +import XMonad.Layout.Spacing +import XMonad.Layout.StackTile +import XMonad.Layout.TwoPane +import XMonad.Layout.WindowArranger +import XMonad.Layout.WindowNavigation +import XMonad.Prompt ( + XPConfig (..), + XPPosition (..), + font, + height, + position, + ) +import qualified XMonad.StackSet as W +import XMonad.Util.EZConfig +import XMonad.Util.Loggers +import XMonad.Util.Paste +import XMonad.Util.Run ( + runInTerm, + runProcessWithInput, + safeSpawn, + spawnPipe, + ) +import XMonad.Util.Ungrab + +myTerminal = "wezterm" + +myBorderWidth :: Dimension +myBorderWidth = 3 -- Sets border width for windows + +myNormColor :: String +myNormColor = "#282c34" -- Border color of normal windows + +myFocusColor :: String +myFocusColor = "#46d9ff" -- Border color of focused windows + +myModMask :: KeyMask +myModMask = mod4Mask + +mylogLayout :: Logger +mylogLayout = withWindowSet $ return . Just . ld + where + ld = description . W.layout . W.workspace . W.current + +-- Gaps around and between windows +-- Changes only seem to apply if I log out then in again +-- Dimensions are given as (Border top bottom right left) +mySpacing :: l a -> ModifiedLayout Spacing l a +mySpacing = + spacingRaw + True -- Only for >1 window + -- The bottom edge seems to look narrower than it is + (Border 0 0 0 0) -- Size of screen edge gaps + True -- Enable screen edge gaps + (Border 5 5 5 5) -- Size of window gaps + True -- Enable window gaps + +myXPConfig :: XPConfig +myXPConfig = + def + { position = Top + , font = "xft:DejaVu Sans:size=9" + , height = 40 + , autoComplete = Just 800 + } + +myLayout = + avoidStruts $ + mySpacing $ + smartBorders $ + mouseResize $ + windowArrange $ + ifWider 1500 (myMulCol ||| myTall ||| Full) (Mirror myTall ||| myStackTile ||| Full) + where + myMulCol = multiCol [1, 1] 0 0.01 (-0.5) + twoPane = TwoPane delta ratio + myTall = Tall nmaster delta ratio + myStackTile = StackTile 1 (3 / 100) (4 / 9) + nmaster = 1 + ratio = 1 / 2 + delta = 3 / 100 + +myKeys :: [([Char], X ())] +myKeys = + [ + ( "" + , spawn + "rofi -m -4 -no-lazy-grab -run-command \"zsh -i -c '{cmd}'\" -show run" + ) + , ("", nextScreen) + , ("", spawnHereNamedScratchpadAction myScratchPads "term") + , ("", withFocused toggleFloat) + , ("", mySwapMaster) + , ("M-", kill) + , ("M-1", myFocusUp) + , ("M-2", myFocusDown) + , ("M-", sendMessage Shrink) + , ("M-", sendMessage Expand) + , ("M-k", spawn "wezterm") + , ("M-4", spawnHereNamedScratchpadAction myScratchPads "pavu") + , + ( "M-p" + , spawn "rofi -m -4 -no-lazy-grab -run-command \"zsh -i -c '{cmd}'\" -show run" + ) + -- , ("C-" , unGrab *> spawn "xdotool key Control_L+Tab") + -- , ("C-" , myFocusDown) + -- , ("M-4" , moveFloat $ namedScratchpadAction myScratchPads "tmux") + ] + ++ workspaceKeys + -- ++ [ ("M-4 " ++ key, fun) + -- | (key, fun) <- + -- [ ("v", spawnHereNamedScratchpadAction myScratchPads "pavu") + -- , ("t", windows (`skipFloating` W.focusDown)) + -- ] + -- ] + ++ [ (" " ++ key, fun) + | (key, fun) <- + [ ("t", sendMessage NextLayout) + , + ( "r" + , spawn + "xmonad --restart" + ) + , ("v", spawn "sh $HOME/.screenlayout/vertical.sh") + , ("b", spawn "sh $HOME/.screenlayout/horizontal.sh") + , ("s", spawn "flameshot gui") + , -- ("f", spawn "fcitx-remote -s fcitx-keyboard-de-nodeadkeys"), + ("w", spawn "$SCRIPTS_DIR/notify_window_title.sh") + , ("p", mkPassPrompt "select pass" sendToClj myXPConfig) + -- , ("h" , spawn "rofi-pass") + -- ("", sendMessage $ Move L), + -- ("", sendMessage $ Move R), + -- ("", sendMessage $ Move U), + -- ("", sendMessage $ Move D) + ] + ] + +-- Query: starts with +(^=?) :: (Eq a) => Query [a] -> [a] -> Query Bool +q ^=? x = isPrefixOf x <$> q + +myScratchPads :: [NamedScratchpad] +myScratchPads = + [ NS + "term" + (myTerminal ++ " --config-file $XDG_CONFIG_HOME/wezterm/scratch.lua") + (title ^=? "[Scratchpad]") + moveFloat + , NS "pavu" "pavucontrol" (className =? "Pavucontrol") moveFloat + ] + where + moveFloat :: Window -> X () + moveFloat a = do + m <- logMaster + l <- logLayout + case (m, trimLayoutModifiers l) of + (_, Just "StackTile") -> + windows $ + W.float + a + (W.RationalRect (1 / 50) (26 / 50) (45 / 50) (20 / 50)) + (True, Just "Mirror Tall") -> + windows $ + W.float + a + (W.RationalRect (1 / 50) (26 / 50) (45 / 50) (20 / 50)) + (False, Just "Mirror Tall") -> + windows $ + W.float + a + (W.RationalRect (1 / 50) (5 / 50) (45 / 50) (20 / 50)) + (True, _) -> + windows $ + W.float + a + (W.RationalRect (26 / 50) (6 / 50) (23 / 50) (20 / 50)) + (False, _) -> + windows $ + W.float + a + (W.RationalRect (1 / 50) (6 / 50) (23 / 50) (20 / 50)) + +myManageHook :: ManageHook +myManageHook = + composeAll + ( concat + [ [isDialog --> doFloat] + , -- , [className =? "Chromium" --> doShift (getWorkspace 2)] + -- , [className =? "Google-chrome" --> doShift (getWorkspace 3)] + -- [className =? "Thunderbird" --> doShift "邮H"], + [className =? "Cider" --> doShift "音"] + , [className =? "Spotify" --> doShift "音"] + , [className =? "Mattermost" --> doShift "聊"] + , [className =? x --> doIgnore | x <- myIgnoreClass] + , [className =? x --> doHideIgnore | x <- myHideIgnoreClass] + , [className =? x --> doCenterFloat | x <- myCenterFloatClass] + , [title =? x --> doCenterFloat | x <- myCenterFloatTitle] + , [title *=? x --> doCenterFloat | x <- myCenterFloatTitleReg] + , [className =? x --> doFullFloat | x <- myFullFloatClass] + ] + ) + where + (*=?) :: (Functor f) => f String -> String -> f Bool + q *=? x = + let matchReg = \a b -> isJust $ matchRegex (mkRegex a) b + in fmap (matchReg x) q + myIgnoreClass = ["trayer"] + myHideIgnoreClass = ["Blueman-applet"] + myCenterFloatClass = + ["Blueman-manager", "zoom", "Pavucontrol", "SimpleScreenRecorder"] + myCenterFloatTitle = ["tmux-Scratchpad", "flameshot"] + myCenterFloatTitleReg = [] + myFullFloatClass = ["MPlayer", "mpv"] + netName = stringProperty "_NET_WM_NAME" + +myConfig = + def + { modMask = myModMask + , terminal = myTerminal + , -- , startupHook = myStartupHook + manageHook = myManageHook + , workspaces = myWorkspaces + , borderWidth = myBorderWidth + , layoutHook = myLayout + , normalBorderColor = myNormColor + , focusedBorderColor = myFocusColor + , -- , logHook = myLogHook + handleEventHook = handleEventHook def <+> fullscreenEventHook + } + -- `removeKeysP` ["M-4"] + `additionalKeysP` myKeys + +runXmonad :: String -> IO () +runXmonad xmobarDir = do + xmonad $ + ewmhFullscreen $ + ewmh $ + withEasySB (xmobarVertical xmobarDir <> xmobarHori xmobarDir) defToggleStrutsKey $ + docks myConfig + +myFocusUp, myFocusDown, mySwapMaster :: X () +myFocusUp = myFocusUpWithNSP myScratchPads +myFocusDown = myFocusDownWithNSP myScratchPads +mySwapMaster = mySwapMasterWithNsp myScratchPads diff --git a/src/MyXmobar.hs b/src/MyXmobar.hs new file mode 100644 index 0000000..7f93268 --- /dev/null +++ b/src/MyXmobar.hs @@ -0,0 +1,103 @@ +module MyXmobar where + +import Data.Functor ((<&>)) +import Data.List +import Data.List.Utils +import MyLogger +import XMonad +import XMonad.Hooks.StatusBar +import XMonad.Hooks.StatusBar.PP +import qualified XMonad.StackSet as W +import XMonad.Util.Loggers +import XMonad.Util.NamedWindows + +{- | Windows should have *some* title, which should not not exceed a + sane length. +-} +ppWindow :: Int -> String -> String +ppWindow limit = + xmobarRaw . (\w -> if null w then "untitled" else w) . shorten limit + +blue, lowWhite, magenta, red, white, yellow :: String -> String +magenta = xmobarColor "#ff79c6" "" +blue = xmobarColor "#bd93f9" "" +white = xmobarColor "#f8f8f2" "" +yellow = xmobarColor "#f1fa8c" "" +red = xmobarColor "#ff5555" "" +lowWhite = xmobarColor "#bbbbbb" "" + +fn1, fn2, fn3 :: String -> String +fn1 = wrap "" "" +fn2 = wrap "" "" +fn3 = wrap "" "" + +extrasWrap :: String -> X (Maybe String) -> String -> X (Maybe String) +extrasWrap pre x post = fmap (wrap pre post) <$> x + +data ExtraString = Normal String | Special (X (Maybe String)) +toX :: ExtraString -> X (Maybe String) +toX e = case e of + Normal s -> return (Just s) + Special x -> x +toPPExtras :: [ExtraString] -> X (Maybe String) +toPPExtras = + foldl + ( \res elem -> do + mres <- res + melem <- toX elem + return $ do + pres <- mres + pelem <- melem + return $ pres ++ pelem + ) + (toX $ Normal "") + +replaceSymbol :: String -> String +replaceSymbol = replace "Ʀ" "R" + +myTitles = + myLogTitles + " " + (fn1 $ blue " ⯰ ") + (wrap (lowWhite "[") (lowWhite "]") . white . show) + (magenta . replaceSymbol) + ( intercalate (fn1 $ yellow " ⯰ ") + . map (yellow . replaceSymbol . ppWindow unfocusedTitleLength) + ) + +myXmobarHoriPP :: PP +myXmobarHoriPP = + def{ppOrder = \[_, _, _, wins] -> [wins], ppExtras = [myTitles]} + +-- , ppRename = \s ws -> fn1 s + +workspacePP :: PP +workspacePP = + def + { ppSep = fn2 $ blue " | " -- blue " •|• " + , ppTitleSanitize = xmobarStrip + , ppCurrent = magenta . wrap " " "" . xmobarBorder "Top" "#8be9fd" 2 + , ppVisible = white + , ppHidden = lowWhite . wrap " " "" + , ppUrgent = red . wrap (yellow "!") (yellow "!") + , ppOrder = \[ws, l, _] -> [ws, l] + -- , ppExtras = [myTitles] + -- , ppRename = \s ws -> fn1 s + } + +xmobarVertical dir = + statusBarPropTo + "_XMONAD_LOG_workspace" + ("xmobar -x 0 " ++ dir ++ "/xmobarrc0.hs") + (pure workspacePP) + +xmobarHori dir = + statusBarPropTo + "_XMONAD_LOG_Hori" + ("xmobar -x 1 " ++ dir ++ "/xmobarrc1.hs") + (pure myXmobarHoriPP) + +-- xmobar3 = statusBarPropTo +-- "_XMONAD_LOG_3" +-- "xmobar -x 1 /home/weiss/.config/xmobar/xmobarrc2.hs" +-- (pure def) diff --git a/weiss-xmonad.cabal b/weiss-xmonad.cabal index f1481f9..738ac6d 100644 --- a/weiss-xmonad.cabal +++ b/weiss-xmonad.cabal @@ -21,8 +21,53 @@ extra-doc-files: -- location: git://github.com/FIXME/weiss-xmonad.git common common-options - build-depends: base >=4.9 && <5 - default-language: Haskell2010 + build-depends: base >=4.9 && <5 + default-language: Haskell2010 + default-extensions: + ApplicativeDo + BangPatterns + ConstraintKinds + DataKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralisedNewtypeDeriving + ImportQualifiedPost + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NoStarIsType + NumericUnderscores + OverloadedStrings + PolyKinds + PostfixOperators + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints @@ -31,17 +76,33 @@ common common-options library import: common-options hs-source-dirs: src - exposed-modules: Lib + exposed-modules: + MyLogger + MyNamedScratchpad + MyPromptPass + MyWindowOperations + MyWorkspace + MyXmobar + MyXMonad + build-depends: + , base , containers - , mtl + , directory + , filepath + , MissingH + , regex-compat + , Unique + , unix + , xmonad + , xmonad-contrib -executable weiss-xmonad-exe - import: common-options - hs-source-dirs: app - main-is: Main.hs - build-depends: weiss-xmonad - ghc-options: -threaded -rtsopts -with-rtsopts=-N +-- executable weiss-xmonad-exe +-- import: common-options +-- hs-source-dirs: app +-- main-is: Main.hs +-- build-depends: weiss-xmonad +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite weiss-xmonad-test import: common-options @@ -51,8 +112,8 @@ test-suite weiss-xmonad-test build-depends: , hspec , HUnit - , weiss-xmonad , QuickCheck + , weiss-xmonad ghc-options: -threaded -rtsopts -with-rtsopts=-N