Merge remote-tracking branch 'ni/master'

5 files changed, 141 insertions, 63 deletions

diff --git a/tv/5pkgs/haskell/flameshot-once.nix b/tv/5pkgs/haskell/flameshot-once.nix
deleted file mode 100644
index c8007ce9e..000000000
--- a/tv/5pkgs/haskell/flameshot-once.nix
+++ /dev/null
@@ -1,20 +0,0 @@
-{ mkDerivation, async, base, blessings, bytestring, dbus, fetchgit
-, iso8601-time, lib, process, random, text, time, unagi-chan, unix
-}:
-mkDerivation {
-  pname = "flameshot-once";
-  version = "1.4.0";
-  src = fetchgit {
-    url = "https://cgit.krebsco.de/flameshot-once";
-    sha256 = "13szgsiwn29aixm5xvs1m7128y5km5xss0ry5ii5y068rc2vysw8";
-    rev = "4475893c2081b3d9db4b7a54d0ce38d0914a17bf";
-    fetchSubmodules = true;
-  };
-  isLibrary = false;
-  isExecutable = true;
-  executableHaskellDepends = [
-    async base blessings bytestring dbus iso8601-time process random
-    text time unagi-chan unix
-  ];
-  license = lib.licenses.mit;
-}
diff --git a/tv/5pkgs/haskell/xmonad-tv/default.nix b/tv/5pkgs/haskell/xmonad-tv/default.nix
index be3eca982..f42f97c2a 100644
--- a/tv/5pkgs/haskell/xmonad-tv/default.nix
+++ b/tv/5pkgs/haskell/xmonad-tv/default.nix
@@ -1,6 +1,5 @@
 { mkDerivation, aeson, base, bytestring, containers, directory
-, extra, filepath, lib, systemd, template-haskell, th-env
-, transformers, unix, X11, xmonad, xmonad-contrib
+, extra, filepath, lib, pager, unix, X11, xmonad, xmonad-contrib
 }:
 mkDerivation {
   pname = "xmonad-tv";
@@ -9,8 +8,9 @@ mkDerivation {
   isLibrary = false;
   isExecutable = true;
   executableHaskellDepends = [
-    aeson base bytestring containers directory extra filepath systemd
-    template-haskell th-env transformers unix X11 xmonad xmonad-contrib
+    aeson base bytestring containers directory extra filepath pager
+    unix X11 xmonad xmonad-contrib
   ];
   license = lib.licenses.mit;
+  mainProgram = "xmonad";
 }
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs b/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs
new file mode 100644
index 000000000..bf8431446
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/XMonad/Hooks/EwmhDesktops/Extra.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module XMonad.Hooks.EwmhDesktops.Extra where
+
+import Control.Monad (when)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (All)
+import Data.Tuple.Extra (both)
+import Graphics.X11.EWMH (getDesktopNames, setDesktopNames)
+import Graphics.X11.EWMH.Atom (_NET_DESKTOP_NAMES)
+import Graphics.X11.Xlib.Display.Extra (withDefaultDisplay)
+import XMonad hiding (workspaces)
+import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace, removeEmptyWorkspaceByTag)
+import XMonad.StackSet (mapWorkspace, tag, workspaces)
+import XMonad.Util.WorkspaceCompare (getSortByIndex)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified XMonad
+
+
+ewmhExtra :: XConfig a -> IO (XConfig a)
+ewmhExtra c = do
+    -- XMonad.Hooks.EwmhDesktops.setDesktopViewport uses _NET_DESKTOP_VIEWPORT
+    -- only if it exists.  This seems to be a harmless issue, but by creating
+    -- the atom here, we suppress the error message:
+    --
+    --    xmonad: X11 error: BadAtom (invalid Atom parameter),
+    --    request code=18, error code=5
+    --
+    _ <-
+      withDefaultDisplay $ \dpy -> internAtom dpy "_NET_DESKTOP_VIEWPORT" False
+
+    initialWorkspaces <-
+      Data.Maybe.fromMaybe (XMonad.workspaces def)
+        <$> withDefaultDisplay getDesktopNames
+
+    return
+      c { handleEventHook = ewmhDesktopsExtraEventHook <> handleEventHook c
+        , rootMask = rootMask c .|. propertyChangeMask
+        , XMonad.workspaces = initialWorkspaces
+        }
+
+ewmhDesktopsExtraEventHook :: Event -> X All
+ewmhDesktopsExtraEventHook = \case
+    PropertyEvent{ev_window, ev_atom} -> do
+      r <- asks theRoot
+      when (ev_window == r && ev_atom == _NET_DESKTOP_NAMES) $
+        withDisplay $ \dpy -> do
+          sort <- getSortByIndex
+
+          oldNames <- gets $ map tag . sort . workspaces . windowset
+          newNames <- fromMaybe oldNames <$> io (getDesktopNames dpy)
+
+          let
+            (renamesFrom, renamesTo) = both Set.fromList $ unzip renames
+
+            renames = go oldNames newNames where
+              go old@(headOld : tailOld) new@(headNew : tailNew) = do
+                let
+                  deleteOld = Set.member headOld deleteNameSet
+                  createNew = Set.member headNew createNameSet
+
+                if
+                  | headOld == headNew ->
+                    -- assert (not deleteOld && not createNew)
+                    go tailOld tailNew
+
+                  | deleteOld && createNew ->
+                    (headOld, headNew) :
+                    go tailOld tailNew
+
+                  | deleteOld ->
+                    go tailOld new
+
+                  | createNew ->
+                    go old tailNew
+
+                  | otherwise ->
+                    -- assert (headOld == headNew)
+                    go tailOld tailNew
+
+              go _ _ = []
+
+            oldNameSet = Set.fromList oldNames
+            newNameSet = Set.fromList newNames
+            deleteNameSet = Set.difference oldNameSet newNameSet
+            createNameSet = Set.difference newNameSet oldNameSet
+
+            deleteNames = Set.toAscList $
+                            Set.difference deleteNameSet renamesFrom
+            createNames = Set.toAscList $
+                            Set.difference createNameSet renamesTo
+
+          mapM_ addHiddenWorkspace createNames
+          mapM_ removeEmptyWorkspaceByTag deleteNames
+          when (not (null renames)) $ do
+            let
+              renameMap = Map.fromList renames
+              rename w =
+                case Map.lookup (tag w) renameMap of
+                  Just newName -> w { tag = newName }
+                  Nothing -> w
+
+            modifyWindowSet $ mapWorkspace rename
+
+          names <- gets $ map tag . sort . workspaces . windowset
+
+          when (names /= newNames) $ do
+            trace $ "setDesktopNames " <> show names
+            io (setDesktopNames names dpy)
+
+      mempty
+
+    _ ->
+      mempty
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/main.hs b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
index 118f2da46..7256963a5 100644
--- a/tv/5pkgs/haskell/xmonad-tv/src/main.hs
+++ b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
@@ -5,16 +5,15 @@ module Main (main) where
 
 import System.Exit (exitFailure)
 import XMonad.Hooks.EwmhDesktops (ewmh)
+import XMonad.Hooks.EwmhDesktops.Extra (ewmhExtra)
 import XMonad.Hooks.RefocusLast (refocusLastLayoutHook, toggleFocus)
 
-import Control.Exception
 import Control.Monad.Extra (whenJustM)
 import qualified Data.Aeson
 import qualified Data.ByteString.Char8
 import qualified Data.List
 import qualified Data.Maybe
 import Graphics.X11.ExtraTypes.XF86
-import Text.Read (readEither)
 import XMonad
 import XMonad.Extra (isFloatingX)
 import System.IO (hPutStrLn, stderr)
@@ -76,11 +75,10 @@ mainNoArgs = do
     myTermFont <- getEnv "XMONAD_TERM_FONT"
     myTermFontWidth <- readEnv "XMONAD_TERM_FONT_WIDTH" :: IO Dimension
     myTermPadding <- readEnv "XMONAD_TERM_PADDING" :: IO Dimension
-    workspaces0 <- getWorkspaces0
     handleShutdownEvent <- newShutdownEventHandler
-    let
-      config =
-        ewmh
+    config <-
+      ewmhExtra
+        $ ewmh
         $ withUrgencyHookC
             BorderUrgencyHook
               { urgencyBorderColor = "#ff0000"
@@ -93,7 +91,6 @@ mainNoArgs = do
             { terminal          = {-pkg:alacritty-tv-}"alacritty"
             , modMask           = mod4Mask
             , keys              = myKeys myTermFont
-            , workspaces        = workspaces0
             , layoutHook =
                 refocusLastLayoutHook $
                 gaps (zip [U,R,D,L] myScreenGaps) $
@@ -125,23 +122,6 @@ mainNoArgs = do
     launch config directories
 
 
-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 True args env) >> return ()
@@ -206,7 +186,7 @@ myKeys font conf = Map.fromList $
 
     , ((_4, xK_Prior), forkFile {-pkg-}"xcalib" ["-invert", "-alter"] Nothing)
 
-    , ((0, xK_Print), forkFile {-pkg-}"flameshot" [] Nothing)
+    , ((0, xK_Print), forkFile {-pkg:flameshot-once-tv-}"flameshot-once" [] Nothing)
 
     , ((_C, xF86XK_Forward), forkFile {-pkg:xdpytools-}"xdpychvt" ["next"] Nothing)
     , ((_C, xF86XK_Back), forkFile {-pkg:xdpytools-}"xdpychvt" ["prev"] Nothing)
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
index 62faf2f00..f211627bf 100644
--- a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
+++ b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
@@ -9,20 +9,21 @@ cabal-version: >=1.10
 executable xmonad
   main-is: main.hs
   build-depends:
-    aeson,
-    base,
-    bytestring,
-    containers,
-    directory,
-    extra,
-    filepath,
-    template-haskell,
-    th-env,
-    unix,
-    X11,
-    xmonad,
-    xmonad-contrib
+      base
+    , X11
+    , aeson
+    , bytestring
+    , containers
+    , directory
+    , extra
+    , filepath
+    , pager
+    , unix
+    , xmonad
+    , xmonad-contrib
   other-modules:
     Shutdown
+    XMonad.Extra
+    XMonad.Hooks.EwmhDesktops.Extra
   default-language: Haskell2010
-  ghc-options: -O2 -Wall -threaded
+  ghc-options: -O2 -Wall