stockholm/tv/5pkgs/simple/xmonad-tv/default.nix

{ pkgs, ... }:
pkgs.writeHaskellPackage "xmonad-tv" {
  executables."xmonad-${builtins.currentSystem}" = {
    extra-depends = [
      "containers"
      "extra"
      "unix"
      "X11"
      "xmonad"
      "xmonad-contrib"
      "xmonad-stockholm"
    ];
    text = /* haskell */ ''
{-# LANGUAGE DeriveDataTypeable #-} -- for XS
{-# LANGUAGE FlexibleContexts #-} -- for xmonad'
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Main where

import System.IO.Error (isDoesNotExistError, tryIOError)
import System.Exit (exitFailure)
import Control.Monad (forever)
import Control.Concurrent (threadDelay)

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 System.Posix.Signals (nullSignal, signalProcess)
import System.Posix.Types (ProcessID)
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


amixerPath :: FilePath
amixerPath = "${pkgs.alsaUtils}/bin/amixer"

urxvtcPath :: FilePath
urxvtcPath = "${pkgs.rxvt_unicode}/bin/urxvtc"

myFont :: String
myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"

main :: IO ()
main = getArgs >>= \case
    [] -> mainNoArgs
    ["--shutdown", pidArg] -> mainShutdown (read pidArg)
    args -> hPutStrLn stderr ("bad arguments: " <> show args) >> exitFailure

mainShutdown :: ProcessID -> IO ()
mainShutdown pid = do
    sendShutdownEvent
    hPutStrLn stderr ("waiting for: " <> show pid)
    result <- tryIOError (waitProcess pid)
    if isSuccess result
      then hPutStrLn stderr ("result: " <> show result <> " [AKA success^_^]")
      else hPutStrLn stderr ("result: " <> show result)
  where
    isSuccess = either isDoesNotExistError (const False)

waitProcess :: ProcessID -> IO ()
waitProcess pid = forever (signalProcess nullSignal pid >> threadDelay 10000)

mainNoArgs :: IO ()
mainNoArgs = do
    workspaces0 <- getWorkspaces0
    xmonad
        $ withUrgencyHook (SpawnUrgencyHook "echo emit Urgency ")
        $ def
            { terminal          = urxvtcPath
            , 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
        urxvtcPath
        ["-name", "root-urxvt", "-e", "/run/wrappers/bin/su", "-"]
        Nothing

spawnTermAt :: String -> X ()
spawnTermAt ws = do
    env <- io getEnvironment
    let env' = ("XMONAD_SPAWN_WORKSPACE", ws) : env
    forkFile urxvtcPath [] (Just env')

myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
myKeys conf = Map.fromList $
    [ ((_4  , xK_Escape ), forkFile "/run/wrappers/bin/slock" [] Nothing)
    , ((_4S , xK_c      ), kill)

    , ((_4  , xK_o      ), forkFile "${pkgs.fzmenu}/bin/otpmenu" [] Nothing)
    , ((_4  , xK_p      ), forkFile "${pkgs.fzmenu}/bin/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 (liftIO . 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 amixerPath 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]
  '';
  };
}