tv xmonad: move to haskell packages

1 files changed, 241 insertions, 0 deletions

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]