Merge remote-tracking branch 'lass/master'

4 files changed, 143 insertions, 52 deletions

diff --git a/tv/5pkgs/haskell/xmonad-tv/src/Build.hs b/tv/5pkgs/haskell/xmonad-tv/src/Build.hs
new file mode 100644
index 0000000..553a129
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/Build.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Build where
+
+import XMonad (Dimension)
+import THEnv.JSON (getCompileEnvJSONExp)
+
+
+myFont :: String
+myFont =
+  "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"
+
+myScreenWidth :: Dimension
+myScreenWidth =
+  $(getCompileEnvJSONExp (id @Dimension) "XMONAD_BUILD_SCREEN_WIDTH")
+
+myTermFontWidth :: Dimension
+myTermFontWidth =
+  $(getCompileEnvJSONExp (id @Dimension) "XMONAD_BUILD_TERM_FONT_WIDTH")
+
+myTermPadding :: Dimension
+myTermPadding =
+  2
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/Shutdown.hs b/tv/5pkgs/haskell/xmonad-tv/src/Shutdown.hs
new file mode 100644
index 0000000..d4a4d93
--- /dev/null
+++ b/tv/5pkgs/haskell/xmonad-tv/src/Shutdown.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Shutdown
+    ( newShutdownEventHandler
+    , shutdown
+    )
+  where
+
+import Control.Applicative ((<|>), empty)
+import Control.Concurrent (threadDelay)
+import Control.Monad (forever, guard, when)
+import Data.Monoid (All(All))
+import System.Directory (XdgDirectory(XdgData), createDirectoryIfMissing, doesFileExist, getAppUserDataDirectory, getXdgDirectory)
+import System.Exit (exitSuccess)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>))
+import System.IO.Error (isDoesNotExistError, tryIOError)
+import System.IO (hPutStrLn, stderr)
+import System.Posix.Process (getProcessID)
+import System.Posix.Signals (nullSignal, signalProcess)
+import System.Posix.Types (ProcessID)
+import XMonad hiding (getXMonadDataDir)
+
+
+-- XXX this is for compatibility with both xmonad<0.17 and xmonad>=0.17
+getXMonadDataDir :: IO String
+getXMonadDataDir = xmEnvDir <|> xmDir <|> xdgDir
+  where
+    -- | Check for xmonad's environment variables first
+    xmEnvDir :: IO String
+    xmEnvDir =
+        maybe empty pure =<< lookupEnv "XMONAD_DATA_DIR"
+
+    -- | Check whether the config file or a build script is in the
+    -- @~\/.xmonad@ directory
+    xmDir :: IO String
+    xmDir = do
+        d <- getAppUserDataDirectory "xmonad"
+        conf  <- doesFileExist $ d </> "xmonad.hs"
+        build <- doesFileExist $ d </> "build"
+        pid <- doesFileExist $ d </> "xmonad.pid"
+
+        -- Place *everything* in ~/.xmonad if yes
+        guard $ conf || build || pid
+        pure d
+
+    -- | Use XDG directories as a fallback
+    xdgDir :: IO String
+    xdgDir = do
+        d <- getXdgDirectory XdgData "xmonad"
+        d <$ createDirectoryIfMissing True d
+
+
+newShutdownEventHandler :: IO (Event -> X All)
+newShutdownEventHandler = do
+    writeProcessIDToFile
+    return handleShutdownEvent
+
+handleShutdownEvent :: Event -> X All
+handleShutdownEvent = \case
+  ClientMessageEvent { ev_message_type = mt } -> do
+    isShutdownEvent <- (mt ==) <$> getAtom "XMONAD_SHUTDOWN"
+    when isShutdownEvent $ do
+      broadcastMessage ReleaseResources
+      writeStateToFile
+      io exitSuccess >> return ()
+    return (All (not isShutdownEvent))
+  _ ->
+    return (All True)
+
+sendShutdownEvent :: IO ()
+sendShutdownEvent = do
+    dpy <- openDisplay ""
+    rw <- rootWindow dpy $ defaultScreen dpy
+    a <- internAtom dpy "XMONAD_SHUTDOWN" False
+    allocaXEvent $ \e -> do
+        setEventType e clientMessage
+        setClientMessageEvent e rw a 32 0 currentTime
+        sendEvent dpy rw False structureNotifyMask e
+    sync dpy False
+
+shutdown :: IO ()
+shutdown = do
+    pid <- readProcessIDFromFile
+    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)
+
+--
+-- PID file stuff
+--
+
+getProcessIDFileName :: IO FilePath
+getProcessIDFileName = (</> "xmonad.pid") <$> getXMonadDataDir
+
+writeProcessIDToFile :: IO ()
+writeProcessIDToFile = do
+    pidFileName <- getProcessIDFileName
+    pid <- getProcessID
+    writeFile pidFileName (show pid)
+
+readProcessIDFromFile :: IO ProcessID
+readProcessIDFromFile = do
+    pidFileName <- getProcessIDFileName
+    read <$> readFile pidFileName
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/main.hs b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
index 81373f4..c921d42 100644
--- a/tv/5pkgs/haskell/xmonad-tv/src/main.hs
+++ b/tv/5pkgs/haskell/xmonad-tv/src/main.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Main (main) where
 
@@ -32,25 +30,9 @@ import Data.Ratio
 import XMonad.Hooks.Place (placeHook, smart)
 import XMonad.Actions.PerWorkspaceKeys (chooseAction)
 
-import XMonad.Stockholm.Pager
-import XMonad.Stockholm.Shutdown
+import Shutdown (shutdown, newShutdownEventHandler)
 
-import THEnv.JSON (getCompileEnvJSONExp)
-
-
-myFont :: String
-myFont = "-schumacher-*-*-*-*-*-*-*-*-*-*-*-iso10646-*"
-
-myScreenWidth :: Dimension
-myScreenWidth =
-  $(getCompileEnvJSONExp (id @Dimension) "XMONAD_BUILD_SCREEN_WIDTH")
-
-myTermFontWidth :: Dimension
-myTermFontWidth =
-  $(getCompileEnvJSONExp (id @Dimension) "XMONAD_BUILD_TERM_FONT_WIDTH")
-
-myTermPadding :: Dimension
-myTermPadding = 2
+import Build (myFont, myScreenWidth, myTermFontWidth, myTermPadding)
 
 
 main :: IO ()
@@ -136,13 +118,6 @@ spawnRootTerm =
         Nothing
 
 
-spawnTermAt :: String -> X ()
-spawnTermAt ws = do
-    env <- io getEnvironment
-    let env' = ("XMONAD_SPAWN_WORKSPACE", ws) : env
-    forkFile {-pkg:rxvt_unicode-}"urxvtc" [] (Just env')
-
-
 myKeys :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
 myKeys conf = Map.fromList $
     [ ((_4  , xK_Escape ), forkFile {-pkg-}"slock" [] Nothing)
@@ -151,11 +126,9 @@ myKeys conf = Map.fromList $
     , ((_4  , xK_o      ), forkFile {-pkg:fzmenu-}"otpmenu" [] Nothing)
     , ((_4  , xK_p      ), forkFile {-pkg:fzmenu-}"passmenu" [] Nothing)
 
-    , ((_4  , xK_x      ), chooseAction spawnTermAt)
+    , ((_4  , xK_x      ), forkFile {-pkg:rxvt_unicode-}"urxvtc" [] Nothing)
     , ((_4C , xK_x      ), spawnRootTerm)
 
-    , ((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_space  ), withFocused $ \w -> ifM (isFloatingX w) xdeny $ sendMessage NextLayout)
@@ -233,23 +206,3 @@ xdeny =
         , "-e", "sleep", "0.05"
         ]
         Nothing
-
-
-pagerConfig :: PagerConfig
-pagerConfig = def
-    { pc_font           = myFont
-    , pc_cellwidth      = 64
-    , pc_matchmethod    = MatchPrefix
-    , 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
-
-
-allWorkspaceNames :: W.StackSet i l a sid sd -> X [i]
-allWorkspaceNames = return . map W.tag . W.workspaces
diff --git a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
index f3bd2e0..a3ddcb0 100644
--- a/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
+++ b/tv/5pkgs/haskell/xmonad-tv/src/xmonad-tv.cabal
@@ -15,14 +15,15 @@ executable xmonad
     containers,
     directory,
     extra,
+    filepath,
     template-haskell,
     th-env,
     unix,
     X11,
     xmonad,
-    xmonad-contrib,
-    xmonad-stockholm
+    xmonad-contrib
   other-modules:
+    Shutdown,
     THEnv.JSON
   default-language: Haskell2010
   ghc-options: -O2 -Wall -threaded