summaryrefslogtreecommitdiffstats
path: root/tv/5pkgs/haskell/xmonad-tv/src
diff options
context:
space:
mode:
Diffstat (limited to 'tv/5pkgs/haskell/xmonad-tv/src')
-rw-r--r--tv/5pkgs/haskell/xmonad-tv/src/Helpers/Path.hs15
-rw-r--r--tv/5pkgs/haskell/xmonad-tv/src/Paths.hs22
-rw-r--r--tv/5pkgs/haskell/xmonad-tv/src/main.hs241
-rw-r--r--tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal25
4 files changed, 303 insertions, 0 deletions
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/Helpers/Path.hs b/tv/5pkgs/haskell/xmonad-tv/src/Helpers/Path.hs
new file mode 100644
index 000000000..1029d60be
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/Helpers/Path.hs
@@ -0,0 +1,15 @@
+module Helpers.Path where
+
+import qualified Data.List
+import qualified System.Directory
+import qualified System.IO.Unsafe
+
+
+findExecutable :: String -> FilePath
+findExecutable =
+ System.IO.Unsafe.unsafePerformIO . find
+ where
+ find name =
+ maybe failure id <$> System.Directory.findExecutable name
+ where
+ failure = error (Data.List.intercalate " " [name, "not found"])
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/Paths.hs b/tv/5pkgs/haskell/xmonad-tv/src/Paths.hs
new file mode 100644
index 000000000..24a809bfe
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/Paths.hs
@@ -0,0 +1,22 @@
+module Paths where
+
+import Helpers.Path
+
+
+amixer :: FilePath
+amixer = findExecutable "amixer"
+
+otpmenu :: FilePath
+otpmenu = findExecutable "otpmenu"
+
+passmenu :: FilePath
+passmenu = findExecutable "passmenu"
+
+slock :: FilePath
+slock = "/run/wrappers/bin/slock"
+
+su :: FilePath
+su = "/run/wrappers/bin/su"
+
+urxvtc :: FilePath
+urxvtc = findExecutable "urxvtc"
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/main.hs b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
new file mode 100644
index 000000000..43461ab98
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
@@ -0,0 +1,241 @@
+{-# LANGUAGE DeriveDataTypeable #-} -- for XS
+{-# LANGUAGE FlexibleContexts #-} -- for xmonad'
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+module Main where
+
+import System.Exit (exitFailure)
+
+import Control.Exception
+import Control.Monad.Extra (whenJustM)
+import Graphics.X11.ExtraTypes.XF86
+import Text.Read (readEither)
+import XMonad
+import System.IO (hPutStrLn, stderr)
+import System.Environment (getArgs, getEnv, getEnvironment, lookupEnv)
+import System.Posix.Process (executeFile)
+import XMonad.Actions.DynamicWorkspaces ( addWorkspacePrompt, renameWorkspace
+ , removeEmptyWorkspace)
+import XMonad.Actions.GridSelect
+import XMonad.Actions.CycleWS (toggleWS)
+import XMonad.Layout.NoBorders ( smartBorders )
+import qualified XMonad.StackSet as W
+import Data.Map (Map)
+import qualified Data.Map as Map
+import XMonad.Hooks.UrgencyHook (SpawnUrgencyHook(..), withUrgencyHook)
+import XMonad.Hooks.ManageHelpers (doCenterFloat)
+import XMonad.Layout.FixedColumn (FixedColumn(..))
+import XMonad.Hooks.Place (placeHook, smart)
+import XMonad.Actions.PerWorkspaceKeys (chooseAction)
+
+import XMonad.Stockholm.Pager
+import XMonad.Stockholm.Rhombus
+import XMonad.Stockholm.Shutdown
+import qualified Paths
+
+
+myFont :: String
+myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"
+
+main :: IO ()
+main = getArgs >>= \case
+ [] -> mainNoArgs
+ ["--shutdown"] -> shutdown
+ args -> hPutStrLn stderr ("bad arguments: " <> show args) >> exitFailure
+
+mainNoArgs :: IO ()
+mainNoArgs = do
+ workspaces0 <- getWorkspaces0
+ handleShutdownEvent <- newShutdownEventHandler
+ xmonad
+ $ withUrgencyHook (SpawnUrgencyHook "echo emit Urgency ")
+ $ def
+ { terminal = Paths.urxvtc
+ , modMask = mod4Mask
+ , keys = myKeys
+ , workspaces = workspaces0
+ , layoutHook = smartBorders $ FixedColumn 1 20 80 10 ||| Full
+ , manageHook =
+ composeAll
+ [ appName =? "fzmenu-urxvt" --> doCenterFloat
+ , appName =? "pinentry" --> doCenterFloat
+ , placeHook (smart (1,0))
+ ]
+ , startupHook =
+ whenJustM (io (lookupEnv "XMONAD_STARTUP_HOOK"))
+ (\path -> forkFile path [] Nothing)
+ , normalBorderColor = "#1c1c1c"
+ , focusedBorderColor = "#f000b0"
+ , handleEventHook = handleShutdownEvent
+ }
+
+
+getWorkspaces0 :: IO [String]
+getWorkspaces0 =
+ try (getEnv "XMONAD_WORKSPACES0_FILE") >>= \case
+ Left e -> warn (displaySomeException e)
+ Right p -> try (readFile p) >>= \case
+ Left e -> warn (displaySomeException e)
+ Right x -> case readEither x of
+ Left e -> warn e
+ Right y -> return y
+ where
+ warn msg = hPutStrLn stderr ("getWorkspaces0: " ++ msg) >> return []
+
+displaySomeException :: SomeException -> String
+displaySomeException = displayException
+
+
+forkFile :: FilePath -> [String] -> Maybe [(String, String)] -> X ()
+forkFile path args env =
+ xfork (executeFile path False args env) >> return ()
+
+spawnRootTerm :: X ()
+spawnRootTerm =
+ forkFile
+ Paths.urxvtc
+ ["-name", "root-urxvt", "-e", Paths.su, "-"]
+ Nothing
+
+spawnTermAt :: String -> X ()
+spawnTermAt ws = do
+ env <- io getEnvironment
+ let env' = ("XMONAD_SPAWN_WORKSPACE", ws) : env
+ forkFile Paths.urxvtc [] (Just env')
+
+myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
+myKeys conf = Map.fromList $
+ [ ((_4 , xK_Escape ), forkFile Paths.slock [] Nothing)
+ , ((_4S , xK_c ), kill)
+
+ , ((_4 , xK_o ), forkFile Paths.otpmenu [] Nothing)
+ , ((_4 , xK_p ), forkFile Paths.passmenu [] Nothing)
+
+ , ((_4 , xK_x ), chooseAction spawnTermAt)
+ , ((_4C , xK_x ), spawnRootTerm)
+
+ --, ((_4 , xK_F1 ), withFocused jojo)
+ --, ((_4 , xK_F1 ), printAllGeometries)
+
+ , ((0 , xK_Menu ), gets windowset >>= allWorkspaceNames >>= pager pagerConfig (windows . W.view) )
+ , ((_S , xK_Menu ), gets windowset >>= allWorkspaceNames >>= pager pagerConfig (windows . W.shift) )
+ , ((_C , xK_Menu ), toggleWS)
+ -- , ((_4 , xK_Menu ), rhombus horseConfig (io . hPutStrLn stderr) ["Correct", "Horse", "Battery", "Staple", "Stuhl", "Tisch"] )
+
+ -- %! Rotate through the available layout algorithms
+ , ((_4 , xK_space ), sendMessage NextLayout)
+ , ((_4S , xK_space ), setLayout $ XMonad.layoutHook conf) -- reset layout
+
+ ---- BinarySpacePartition
+ --, ((_4 , xK_l), sendMessage $ ExpandTowards R)
+ --, ((_4 , xK_h), sendMessage $ ExpandTowards L)
+ --, ((_4 , xK_j), sendMessage $ ExpandTowards D)
+ --, ((_4 , xK_k), sendMessage $ ExpandTowards U)
+ --, ((_4S , xK_l), sendMessage $ ShrinkFrom R)
+ --, ((_4S , xK_h), sendMessage $ ShrinkFrom L)
+ --, ((_4S , xK_j), sendMessage $ ShrinkFrom D)
+ --, ((_4S , xK_k), sendMessage $ ShrinkFrom U)
+ --, ((_4 , xK_n), sendMessage Rotate)
+ --, ((_4S , xK_n), sendMessage Swap)
+
+ ---- mouseResizableTile
+ --, ((_4 , xK_u), sendMessage ShrinkSlave)
+ --, ((_4 , xK_i), sendMessage ExpandSlave)
+
+ -- move focus up or down the window stack
+ --, ((_4 , xK_m ), windows W.focusMaster)
+ , ((_4 , xK_j ), windows W.focusDown)
+ , ((_4 , xK_k ), windows W.focusUp)
+
+ -- modifying the window order
+ , ((_4S , xK_m ), windows W.swapMaster)
+ , ((_4S , xK_j ), windows W.swapDown)
+ , ((_4S , xK_k ), windows W.swapUp)
+
+ -- resizing the master/slave ratio
+ , ((_4 , xK_h ), sendMessage Shrink) -- %! Shrink the master area
+ , ((_4 , xK_l ), sendMessage Expand) -- %! Expand the master area
+
+ -- floating layer support
+ , ((_4 , xK_t ), withFocused $ windows . W.sink) -- make tiling
+
+ -- increase or decrease number of windows in the master area
+ , ((_4 , xK_comma ), sendMessage $ IncMasterN 1)
+ , ((_4 , xK_period ), sendMessage $ IncMasterN (-1))
+
+ , ((_4 , xK_a ), addWorkspacePrompt def)
+ , ((_4 , xK_r ), renameWorkspace def)
+ , ((_4 , xK_Delete ), removeEmptyWorkspace)
+
+ , ((_4 , xK_Return ), toggleWS)
+ --, (0 , xK_Menu ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.view)
+ --, (_4 , xK_v ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.view)
+ --, (_4S , xK_v ) & \k -> (k, gridselectWorkspace wsGSConfig { gs_navigate = makeGSNav k } W.shift)
+ --, (_4 , xK_b ) & \k -> (k, goToSelected wGSConfig { gs_navigate = makeGSNav k })
+ , ((noModMask, xF86XK_AudioLowerVolume), amixer ["sset", "Master", "5%-"])
+ , ((noModMask, xF86XK_AudioRaiseVolume), amixer ["sset", "Master", "5%+"])
+ , ((noModMask, xF86XK_AudioMute), amixer ["sset", "Master", "toggle"])
+ ]
+ where
+ _4 = mod4Mask
+ _C = controlMask
+ _S = shiftMask
+ _M = mod1Mask
+ _4C = _4 .|. _C
+ _4S = _4 .|. _S
+ _4M = _4 .|. _M
+ _4CM = _4 .|. _C .|. _M
+ _4SM = _4 .|. _S .|. _M
+
+ amixer args = forkFile Paths.amixer args Nothing
+
+
+pagerConfig :: PagerConfig
+pagerConfig = def
+ { pc_font = myFont
+ , pc_cellwidth = 64
+ --, pc_cellheight = 36 -- TODO automatically keep screen aspect
+ --, pc_borderwidth = 1
+ --, pc_matchcolor = "#f0b000"
+ , pc_matchmethod = MatchPrefix
+ --, pc_colors = pagerWorkspaceColors
+ , pc_windowColors = windowColors
+ }
+ where
+ windowColors _ _ _ True _ = ("#ef4242","#ff2323")
+ windowColors wsf m c u wf = do
+ let y = defaultWindowColors wsf m c u wf
+ if m == False && wf == True
+ then ("#402020", snd y)
+ else y
+
+horseConfig :: RhombusConfig
+horseConfig = def
+ { rc_font = myFont
+ , rc_cellwidth = 64
+ --, rc_cellheight = 36 -- TODO automatically keep screen aspect
+ --, rc_borderwidth = 1
+ --, rc_matchcolor = "#f0b000"
+ , rc_matchmethod = MatchPrefix
+ --, rc_colors = pagerWorkspaceColors
+ --, rc_paint = myPaint
+ }
+
+wGSConfig :: GSConfig Window
+wGSConfig = def
+ { gs_cellheight = 20
+ , gs_cellwidth = 192
+ , gs_cellpadding = 5
+ , gs_font = myFont
+ , gs_navigate = navNSearch
+ }
+
+
+(&) :: a -> (a -> c) -> c
+(&) = flip ($)
+
+allWorkspaceNames :: W.StackSet i l a sid sd -> X [i]
+allWorkspaceNames ws =
+ return $ map W.tag (W.hidden ws) ++ [W.tag $ W.workspace $ W.current ws]
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
new file mode 100644
index 000000000..f10bc4aeb
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
@@ -0,0 +1,25 @@
+name: xmonad-tv
+version: 1.0.0
+license: MIT
+author: tv <tv@krebsco.de>
+maintainer: tv <tv@krebsco.de>
+build-type: Simple
+cabal-version: >=1.10
+
+executable xmonad
+ main-is: main.hs
+ build-depends:
+ base,
+ containers,
+ directory,
+ extra,
+ unix,
+ X11,
+ xmonad,
+ xmonad-contrib,
+ xmonad-stockholm
+ other-modules:
+ Helpers.Path,
+ Paths
+ default-language: Haskell2010
+ ghc-options: -O2 -Wall -threaded
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-04 23:46:28 +0000