dotfiles/dotfiles/config/xmonad/xmonad.hs

{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances,
             MultiParamTypeClasses, ExistentialQuantification,
             FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}
module Main where

import           Codec.Binary.UTF8.String as UTF8
import qualified Codec.Binary.UTF8.String as UTF8String (encode)
import qualified Control.Arrow as A
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Aeson
import qualified Data.ByteString.Lazy as B
import           Data.Char
import           Data.Foldable
import           Data.List
import           Data.List.Split
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import qualified Data.MultiMap as MM
import           Data.Proxy
import           Data.Tuple.Sequence (sequenceT)
import           Data.Typeable
import           Foreign.C.Types
import           Graphics.X11.ExtraTypes.XF86
import           Network.HostName
import           PagerHints
import           Safe
import           System.Directory
import           System.Environment.XDG.DesktopEntry
import           System.FilePath.Posix
import           System.IO.Unsafe
import           System.Process
import           Text.Printf
import           Unsafe.Coerce
import           XMonad.Main (launch)
import           XMonad.Core (getDirectories)
import           XMonad hiding ( (|||) )
import           XMonad.Actions.CycleWS hiding (nextScreen)
import           XMonad.Actions.CycleWorkspaceByScreen
import qualified XMonad.Actions.DynamicWorkspaceOrder as DWO
import           XMonad.Actions.DynamicWorkspaces hiding (withWorkspace, renameWorkspace)
import           XMonad.Actions.Minimize
import           XMonad.Actions.Navigation2D
import qualified XMonad.Actions.SwapWorkspaces as SW
import           XMonad.Actions.UpdatePointer
import           XMonad.Actions.WindowBringer
import           XMonad.Actions.WindowGo
import           XMonad.Actions.WorkspaceNames
import           XMonad.Config ()
import           XMonad.Hooks.EwmhDesktops
import           XMonad.Hooks.FadeInactive
import           XMonad.Hooks.ManageDocks
import           XMonad.Hooks.ManageHelpers
import           XMonad.Hooks.Minimize
import           XMonad.Hooks.WorkspaceHistory
import           XMonad.Layout.Accordion
import           XMonad.Layout.BoringWindows
import           XMonad.Layout.Cross
import           XMonad.Layout.LayoutCombinators
import           XMonad.Layout.LayoutModifier
import           XMonad.Layout.LimitWindows
import           XMonad.Layout.MagicFocus
import           XMonad.Layout.Minimize
import           XMonad.Layout.MultiColumns
import           XMonad.Layout.MultiToggle
import           XMonad.Layout.MultiToggle.Instances
import           XMonad.Layout.NoBorders
import qualified XMonad.Layout.Renamed as RN
import           XMonad.Layout.Spacing
import           XMonad.Layout.Tabbed
import qualified XMonad.StackSet as W
import           XMonad.Util.CustomKeys
import qualified XMonad.Util.Dmenu as DM
import qualified XMonad.Util.ExtensibleState as XS
import           XMonad.Util.Minimize
import           XMonad.Util.NamedScratchpad
import           XMonad.Util.NamedWindows (getName)
import           XMonad.Util.Run
import           XMonad.Util.WorkspaceCompare

myConfig = def
  { modMask = mod4Mask
  , terminal = "alacritty"
  , manageHook = myManageHook <+> manageHook def
  , layoutHook = myLayoutHook
  , borderWidth = 0
  , normalBorderColor = "#000000"
  , focusedBorderColor = "#ffff00"
  , logHook =
      updatePointer (0.5, 0.5) (0, 0) +++
      toggleFadeInactiveLogHook 0.9 +++ workspaceHistoryHook +++
      setWorkspaceNames
  , handleEventHook =
      fullscreenEventHook +++ followIfNoMagicFocus +++ minimizeEventHook
  , startupHook = myStartup
  , keys = customKeys (const []) addKeys
  }
  where
    x +++ y = mappend y x

myNavigation2DConfig = def { defaultTiledNavigation = centerNavigation }

main = do
  dirs <- getDirectories
  (flip launch dirs) . docks . pagerHints . ewmh . withNavigation2DConfig myNavigation2DConfig $ myConfig

-- Utility functions

-- Log to a file from anywhere
writeToHomeDirLog stuff = io $ getLogFile >>= flip appendFile (stuff ++ "\n")
  where getLogFile = (</> "temp" </> "xmonad.log") <$> getHomeDirectory

logWindowSet message =
  withWindowSet $ \ws -> writeToHomeDirLog $ printf "%s -- " message $ show ws

xRunCommand cmd = void $ io $ readCreateProcess (shell cmd) ""

(<..>) :: Functor f => (a -> b) -> f (f a) -> f (f b)
(<..>) = fmap . fmap

forkM :: Monad m => (i -> m a) -> (i -> m b) -> i -> m (a, b)
forkM a b = sequenceT . (a A.&&& b)

tee :: Monad m => (i -> m a) -> (i -> m b) -> i -> m a
tee = (fmap . fmap . fmap) (fmap fst) forkM

(>>=/) :: Monad m => m a -> (a -> m b) -> m a
(>>=/) a = (a >>=) . tee return

findM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
findM f = runMaybeT . msum . map (MaybeT . f)

if' :: Bool -> a -> a -> a
if' True  x _ = x
if' False _ y = y

ifL :: a -> a -> Bool -> a
ifL a b c = if' c a b

infixl 4 <$$>
(<$$>) :: Functor f => f (a -> b) -> a -> f b
functor <$$> value = ($ value) <$> functor

toggleInMap' :: Ord k => Bool -> k -> M.Map k Bool -> M.Map k Bool
toggleInMap' d k m =
  let existingValue = M.findWithDefault d k m
  in M.insert k (not existingValue) m

toggleInMap :: Ord k => k -> M.Map k Bool -> M.Map k Bool
toggleInMap = toggleInMap' True

maybeRemap k = M.findWithDefault k k

(<$.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c
(<$.>) l r = fmap l . r

withFocusedR f = withWindowSet (f . W.peek)

withFocusedD d f = maybe (return d) f <$> withWindowSet (return . W.peek)

withWorkspaceR f = withWindowSet $ f . W.workspace . W.current

mapP = mapP' id

mapP' f f' = map (f A.&&& f')

minimizedWindows = withMinimized return

visibleWindows =
  (\\) <$> withWorkspaceR (return . W.integrate' . W.stack)
         <*> minimizedWindows

followingWindow action = do
  orig <- withWindowSet (return . W.peek)
  res <- action
  whenJust orig $ windows . W.focusWindow
  return res

myDmenuArgs = ["-dmenu", "-i", "-show-icons"]

myDmenu = DM.menuArgs "rofi" myDmenuArgs

getWorkspaceDmenu = myDmenu (workspaces myConfig)

-- Selectors

isHangoutsTitle = isPrefixOf "Google Hangouts"
isGmailTitle t = isInfixOf "@gmail.com" t && isInfixOf "Gmail" t
isChromeClass = isInfixOf "chrome"
chromeSelectorBase = isChromeClass <$> className

chromeSelector =
  chromeSelectorBase <&&>
  (\t -> not $ any ($ t) [isHangoutsTitle, isGmailTitle]) <$> title
spotifySelector = className =? "Spotify"
emacsSelector = className =? "Emacs"
transmissionSelector = fmap (isPrefixOf "Transmission") title
hangoutsSelector = chromeSelectorBase <&&> fmap isHangoutsTitle title
gmailSelector = chromeSelectorBase <&&> fmap isGmailTitle title
volumeSelector = className =? "Pavucontrol"

virtualClasses =
  [ (hangoutsSelector, "Hangouts")
  , (gmailSelector, "Gmail")
  , (chromeSelector, "Chrome")
  , (transmissionSelector, "Transmission")
  ]

-- Commands

hangoutsCommand = "start_hangouts.sh"
gmailCommand = "start_chrome.sh --new-window https://mail.google.com/mail/u/0/#inbox"
spotifyCommand = "spotify"
chromeCommand = "start_chrome.sh"
emacsCommand = "emacsclient -c"
htopCommand = "alacritty -e htop -t htop"
transmissionCommand = "transmission-gtk"
volumeCommand = "pavucontrol"

-- Startup hook

tvScreenId :: ScreenId
tvScreenId = 1

disableTVFading = setFading (Just tvScreenId) False

hostNameToAction =
  M.fromList [ ("imalison-arch", disableTVFading >> setToggleActiveAll GAPS True)
             , ("imalison-uber-loaner", return ())
             ]

myStartup = do
  spawn "systemctl --user start wm.target"
  hostName <- io getHostName
  M.findWithDefault (return ()) hostName hostNameToAction

-- Manage hook

myManageHook = maybeReplaceTargetHook <+>
  composeOne
  [ isFullscreen -?> doFullFloat ]

-- Toggles

unmodifyLayout (ModifiedLayout _ x') =  x'

selectLimit =
  myDmenu ["2", "3", "4"] >>= (setLimit . read)

data MyToggles
  = LIMIT
  | GAPS
  | MAGICFOCUS
  deriving (Read, Show, Eq, Typeable)

instance Transformer MyToggles Window where
  transform LIMIT x k = k (limitSlice 2 x) unmodifyLayout
  transform GAPS x k = k (smartSpacing 10 x) unmodifyLayout
  transform MAGICFOCUS x k = k (magicFocus x) unmodifyLayout

myToggles = [LIMIT, GAPS, MAGICFOCUS]
otherToggles = [NBFULL, MIRROR]
toggleHandlers = [(Toggle GAPS, toggleAll)]

instance Eq (Toggle Window) where
  (Toggle v) == v2 = Just v == fromToggle v2

fromToggle :: forall t. Typeable t => Toggle Window -> Maybe t
fromToggle (Toggle v) =
  if typeOf v == typeRep (Proxy :: Proxy t) then
    Just $ unsafeCoerce v
  else
    Nothing

currentWorkspace = W.workspace . W.current <$> gets windowset
isToggleActiveInCurrent t = currentWorkspace >>= isToggleActive t

followIfNoMagicFocus =
  followOnlyIf $ maybe False not <$> isToggleActiveInCurrent MAGICFOCUS

togglesMap =
  fmap M.fromList $ sequence $
  map toggleTuple myToggles ++ map toggleTuple otherToggles
  where
    toggleTuple toggle = do
      toggleString <- toggleToStringWithState toggle
      return (toggleString, Toggle toggle)

toggleStateToString = maybe "N/A" (ifL "ON" "OFF")

toggleToStringWithState :: (Transformer t Window, Show t) => t -> X String
toggleToStringWithState toggle =
  printf "%s (%s)" (show toggle) . toggleStateToString <$>
  isToggleActiveInCurrent toggle

selectToggle =
  togglesMap >>= DM.menuMapArgs "rofi" myDmenuArgs >>= flip whenJust runToggle

runToggle toggle =
  let f = fromMaybe sendMessage $ lookup toggle toggleHandlers
      in f toggle

toggleAll (Toggle toggle) = void $ runMaybeT $ do
  active <- MaybeT $ isToggleActiveInCurrent toggle
  lift $ setToggleActiveAll toggle (not active)

mapWorkspaces f = withWindowSet $ \ws -> do
   let c = W.workspace . W.current $ ws
       v = map W.workspace . W.visible $ ws
       h = W.hidden ws
   mapM f (c : v ++ h)

toggleInState t s ws  = fmap (/= s) (isToggleActive t ws)

setToggleActive toggle active ws =
  toggleInState toggle (Just active) ws >>=/
  flip when (sendMessageWithNoRefresh (Toggle toggle) ws >> windows id)

-- Ambiguous type reference without signature
setToggleActiveCurrent :: (Transformer t Window) => t -> Bool -> X ()
setToggleActiveCurrent t a = void $ currentWorkspace >>= setToggleActive t a

setToggleActiveAll :: (Transformer t Window) => t -> Bool -> X ()
setToggleActiveAll t a = void $ mapWorkspaces (setToggleActive t a)

deactivateFull = setToggleActiveCurrent NBFULL False

toggleOr toggle toState action =
  (currentWorkspace >>= setToggleActive toggle toState) >>= ((`when` action) . not)

deactivateFullOr = toggleOr NBFULL False
deactivateFullAnd action = sequence_ [deactivateFull, action]

andDeactivateFull action = sequence_ [action, deactivateFull]

goFullscreen = sendMessage $ JumpToLayout "Tabbed Simplest"

-- Layout setup

myTabConfig =
  def { activeBorderColor = "#66cccc" }

rename newName = RN.renamed [RN.Replace newName]

layoutsStart layout = (layout, [Layout layout])

(|||!) (joined, layouts) newLayout =
    (joined ||| newLayout, layouts ++ [Layout newLayout])

layoutInfo =
  layoutsStart (rename "4 Columns" $ (multiCol [1, 1, 1] 2 0.0 (-0.5))) |||!
  rename "3 Columns" (multiCol [1, 1] 2 0.01 (-0.5)) |||!
  rename "Large Main" (Tall 1 (3 / 100) (3 / 4)) |||!
  rename "2 Columns" (Tall 1 (3 / 100) (1 / 2)) |||!
  Accordion |||! simpleCross |||! myTabbed
    where
      myTabbed = tabbed shrinkText myTabConfig

layoutList = snd layoutInfo

layoutNames = [description layout | layout <- layoutList]

selectLayout = myDmenu layoutNames >>= (sendMessage . JumpToLayout)

myLayoutHook =
  avoidStruts .
  minimizeNoDescription .
  boringAuto .
  mkToggle1 MIRROR .
  mkToggle1 LIMIT .
  mkToggle1 GAPS .
  mkToggle1 MAGICFOCUS .
  mkToggle1 NBFULL .
  lessBorders Screen $ fst layoutInfo

-- WindowBringer

myWindowBringerConfig =
  def { menuCommand = "rofi"
      , menuArgs = myDmenuArgs ++ ["-format", "i"]
      , windowTitler = myDecorateName
      }

classIfMatches window entry =
  if' <$> runQuery (fst entry) window <*>
      pure (Just $ snd entry) <*>
      pure Nothing

getClassRaw w = fmap resClass $ withDisplay $ io . flip getClassHint w

getVirtualClass = flip findM virtualClasses . classIfMatches

getClass w = fromMaybe <$> getClassRaw w <*> getVirtualClass w

desktopEntriesMap :: MM.MultiMap String DesktopEntry
desktopEntriesMap =
  unsafePerformIO $
        indexDesktopEntriesByClassName <$> getDirectoryEntriesDefault

lookupIconFromClasses classes =
  getFirst $ fold $ First . deIcon <$>
             (classes >>= idAndLower >>= flip MM.lookup desktopEntriesMap)
    where idAndLower value = [value, map toLower value]

xGetWindowProperty8 :: Atom -> Window -> X (Maybe [CChar])
xGetWindowProperty8 a w = withDisplay $ \dpy -> io $ getWindowProperty8 dpy a w

getEWMHClasses w = do
  atom <- withDisplay $ \d -> io $ internAtom d "WM_CLASS" False
  mValue <- fmap (UTF8.decode . map fromIntegral) <$> xGetWindowProperty8 atom w
  pure $ filter (not . null) $ splitOn "\NUL" $ join $ maybeToList mValue

myDecorateName :: WindowSpace -> Window -> X String
myDecorateName ws w = do
  name <- show <$> getName w
  classes <- getEWMHClasses w
  classTitle <- getClass w
  workspaceToName <- getWorkspaceNames'
  let iconName = fromMaybe (map toLower $ head classes) $ lookupIconFromClasses classes
      entryString = printf "%-20s%-40s %+30s in %s \0icon\x1f%s"
                    classTitle (take 40 name) " " (fromMaybe "" $ workspaceToName (W.tag ws)) iconName
  return entryString

data ChromeInfo = ChromeInfo
  { tabId :: Int
  , tabUri :: String
  , tabTitle :: String
  } deriving (Eq, Show)

getChromeTabInfo = do
  output <- runProcessWithInput "chromix-too" ["ls"] ""
  return $ M.fromList $ map parseChromixLine $ lines output
    where parseChromixLine line =
            case splitOn " " line of
              [] -> undefined
              tid:uri:rest -> let ttl = concat rest in
                              (printf "%s - %s" tid ttl :: String,
                               ChromeInfo { tabId = read tid
                                          , tabUri = uri
                                          , tabTitle = ttl
                                          })
              [_] -> undefined

selectChromeTab WindowBringerConfig { menuCommand = cmd
                                    , menuArgs = args
                                    } =
  liftIO getChromeTabInfo >>= void . DM.menuMapArgs cmd args

chromeTabAction doSplit action selected =
  case selected of
    Left wid -> action wid
    Right ChromeInfo { tabId = tid } ->
      liftIO $ do
        let command = if doSplit then
                "split_tab_by_id.sh %s"
              else
                "focus_tab_by_id.sh %s"
        spawn $ printf command $ show tid
        return ()

menuIndexArgs :: MonadIO m => String -> [String] -> [(String, a)] ->
               m (Maybe a)
menuIndexArgs menuCmd args selectionPairs = do
  selection <- menuFunction (map fst selectionPairs)
  pure $ snd <$> (readMay selection >>= atMay selectionPairs)
      where
        menuFunction = DM.menuArgs menuCmd args

-- This needs access to X in order to unminimize, which means that it can't be
-- done with the existing window bringer interface
myWindowAct c@WindowBringerConfig {menuCommand = cmd, menuArgs = args}
            filterVisible action = do
  visible <- visibleWindows
  currentlyFullscreen <- isToggleActiveInCurrent NBFULL
  let actualConfig =
        if fromMaybe False currentlyFullscreen
        then c
        else
          if filterVisible
          then c {windowFilter = not . flip elem visible}
          else c
  ws <- M.toList <$> windowMap' actualConfig
  selection <- menuIndexArgs cmd args ws
  whenJust selection action

doBringWindow window =
  maximizeWindow window >> windows (W.focusWindow window . bringWindow window)

myWindowAction filterVisible =
  andDeactivateFull . maybeUnminimizeAfter . myWindowAct myWindowBringerConfig filterVisible

myGoToWindow =
  myWindowAction False $ windows . greedyFocusWindow

myBringWindow = myWindowAction True $ doBringWindow

myReplaceWindow =
  swapMinimizeStateAfter $
  myWindowAct myWindowBringerConfig True $ (windows . swapFocusedWith)

-- Workspace Names for EWMH

setWorkspaceNames :: X ()
setWorkspaceNames = withWindowSet $ \s -> withDisplay $ \dpy -> do
  sort' <- getSortByIndex
  let ws = sort' $ W.workspaces s
      tagNames = map W.tag ws
      getName tag = maybe "" (" " ++) <$> getWorkspaceName tag
      getFullName :: String -> X String
      getFullName tag = printf "%s%s" tag <$> getName tag
  names <- mapM getFullName tagNames
  r <- asks theRoot
  a <- getAtom "_NET_DESKTOP_FULL_NAMES"
  c <- getAtom "UTF8_STRING"
  let names' = map fromIntegral $ concatMap ((++[0]) . UTF8String.encode) names
  io $ changeProperty8 dpy r a c propModeReplace names'


-- Toggleable fade

newtype ToggleFade a =
  ToggleFade { fadesMap :: M.Map a Bool }
  deriving (Typeable, Read, Show)

instance (Typeable a, Read a, Show a, Ord a) =>
         ExtensionClass (ToggleFade a) where
  initialValue = ToggleFade M.empty
  extensionType = PersistentExtension

fadeEnabledFor query =
  M.findWithDefault True <$> query <*> liftX (fadesMap <$> XS.get)

fadeEnabledForWindow = fadeEnabledFor ask
fadeEnabledForWorkspace = fadeEnabledFor getWindowWorkspace
fadeEnabledForScreen = fadeEnabledFor getWindowScreen

getScreens = withWindowSet $ return . W.screens
getWindowWorkspace' = W.findTag <$> ask <*> liftX (withWindowSet return)
getWindowWorkspace = flip fromMaybe <$> getWindowWorkspace' <*> pure "1"
getWorkspaceToScreen =
  M.fromList . mapP' (W.tag . W.workspace) W.screen <$> getScreens
getWindowScreen = M.lookup <$> getWindowWorkspace <*> liftX getWorkspaceToScreen
getCurrentScreen = join (withFocusedD Nothing (runQuery getWindowScreen))

fadeCondition =
  isUnfocused <&&> fadeEnabledForWindow <&&>
  fadeEnabledForWorkspace <&&> fadeEnabledForScreen

toggleFadeInactiveLogHook = fadeOutLogHook . fadeIf fadeCondition

toggleFadingForActiveWindow = withWindowSet $
  maybe (return ()) toggleFading . W.peek

toggleFadingForActiveWorkspace =
  withWindowSet $ \ws -> toggleFading $ W.currentTag ws

toggleFadingForActiveScreen = getCurrentScreen >>= toggleFading

toggleFading w = setFading' $ toggleInMap w

setFading w f = setFading' $ M.insert w f

setFading' f =
  fmap (ToggleFade . f . fadesMap) XS.get >>= XS.put

-- Minimize not in class

restoreFocus action =
  withFocused $ \orig -> action >> windows (W.focusWindow orig)

getCurrentWS = W.stack . W.workspace . W.current

withWorkspace f = withWindowSet $ \ws -> maybe (return ()) f (getCurrentWS ws)

currentWS = withWindowSet $ return . getCurrentWS

workspaceWindows = maybe [] W.integrate <$> currentWS

getMinMaxWindows =
  partition <$> (flip elem <$> minimizedWindows) <*> workspaceWindows

maximizedWindows = fmap snd getMinMaxWindows

maximizedOtherClass =
  intersect <$> maximizedWindows <*>
  (currentWS >>= maybe (return []) windowsWithUnfocusedClass)

minimizedSameClass =
  intersect <$> minimizedWindows <*>
  (currentWS >>= maybe (return []) windowsWithFocusedClass)

getClassMatchesWindow w = (==) <$> getClass w
getClassMatchesCurrent = join $ withFocusedD (`seq` False) getClassMatchesWindow

minimizeOtherClassesInWorkspace =
  actOnWindowsInWorkspace minimizeWindow windowsWithUnfocusedClass
maximizeSameClassesInWorkspace =
  actOnWindowsInWorkspace maybeUnminimize windowsWithFocusedClass

-- Type annotation is needed to resolve ambiguity
actOnWindowsInWorkspace :: (Window -> X ())
                        -> (W.Stack Window -> X [Window])
                        -> X ()
actOnWindowsInWorkspace windowAction getWindowsAction = restoreFocus $
  withWorkspace (getWindowsAction >=> mapM_ windowAction)

-- XXX: The idea behind this was that the normal fullscreen can be annoying if a
-- new window opens, but this behavior is even more annoying than that, so
-- nevermind
goFullscreenDWIM =
  withWorkspace $ \ws -> do
    wins <- windowsWithFocusedClass ws
    if length wins > 1
      then goFullscreen
      else minimizeOtherClassesInWorkspace

windowsWithUnfocusedClass ws = windowsWithOtherClasses (W.focus ws) ws
windowsWithFocusedClass ws = windowsWithSameClass (W.focus ws) ws
windowsWithOtherClasses = windowsMatchingClassPredicate (/=)
windowsWithSameClass = windowsMatchingClassPredicate (==)

windowsMatchingClassPredicate predicate window workspace =
  windowsSatisfyingPredicate workspace $ do
    windowClass <- getClass window
    return $ predicate windowClass

windowsSatisfyingPredicate workspace getPredicate = do
  predicate <- getPredicate
  filterM (\w -> predicate <$> getClass w) (W.integrate workspace)

getMatchingUnmatching =
  partition <$> ((. snd) <$> getClassMatchesCurrent) <*> getWindowClassPairs

getWindowClassPairs = join $ mapM windowToClassPair <$> workspaceWindows

windowToClassPair w = (,) w <$> getClass w

windowIsMinimized w = do
  minimized <- XS.gets minimizedStack
  return $ w `elem` minimized

maybeUnminimize w = windowIsMinimized w >>= flip when (maximizeWindow w)

maybeUnminimizeFocused = withFocused maybeUnminimize

maybeUnminimizeAfter = (>> maybeUnminimizeFocused)

maybeUnminimizeClassAfter = (>> maximizeSameClassesInWorkspace)

sameClassOnly action =
  action >> minimizeOtherClassesInWorkspace >> maximizeSameClassesInWorkspace

restoreAll = mapM_ maximizeWindow

restoreAllMinimized = minimizedWindows >>= restoreAll

restoreOrMinimizeOtherClasses = null <$> maximizedOtherClass >>=
  ifL restoreAllMinimized minimizeOtherClassesInWorkspace

restoreThisClassOrMinimizeOtherClasses = minimizedSameClass >>= \ws ->
  if' (null ws) minimizeOtherClassesInWorkspace $ restoreAll ws

getClassPair w = flip (,) w <$> getClass w

windowClassPairs = withWindowSet $ mapM getClassPair . W.allWindows
classToWindowMap = MM.fromList <$> windowClassPairs
allClasses = sort . MM.keys <$> classToWindowMap
thisClass = withWindowSet $ sequence . (getClass <$.> W.peek)

nextClass = do
  classes <- allClasses
  current <- thisClass
  let index = join $ elemIndex <$> current <$$> classes
  return $ fmap (\i -> cycle classes !! (i + 1)) index

classWindow c = do
  m <- classToWindowMap
  return $ join $ listToMaybe <$> (flip MM.lookup m <$> c)

nextClassWindow = nextClass >>= classWindow

focusNextClass' =
  join $ windows . maybe id greedyFocusWindow <$> nextClassWindow
focusNextClass = sameClassOnly focusNextClass'

selectClass = join $ myDmenu <$> allClasses

-- Chrome auto minimization

data ReplaceOnNew
  = NoTarget
  | DontTarget
  | Target Window
  deriving (Typeable, Read, Show)

instance ExtensionClass ReplaceOnNew where
  initialValue = NoTarget
  extensionType = PersistentExtension

mapWindows f = W.mapWorkspace workspaceHelper
  where
    stackHelper stack = W.Stack
          { W.focus = f $ W.focus stack
          , W.up = map f $ W.up stack
          , W.down = map f $ W.down stack
          }
    workspaceHelper ws@W.Workspace {W.stack = stack} =
      ws { W.stack = stackHelper <$> stack }

swapWindows a b =
  mapWindows helper
  where helper w
          | w == a = b
          | w == b = a
          | otherwise = w

getTarget = do
  t <- XS.get
  case t of
    Target w -> return $ Just w
    DontTarget -> return Nothing
    NoTarget -> return Nothing

maybeReplaceTarget :: Window -> X ()
maybeReplaceTarget window = do
  t <- getTarget
      -- We have an insertUp here to ensure the target isn't deleted
  let modifyStackSet target = W.insertUp target . swapWindows window target
      replaceTarget target =
        windows (modifyStackSet target) >> minimizeWindow target >>
        XS.put (initialValue :: ReplaceOnNew)
  whenJust t replaceTarget

maybeReplaceTargetHook = ask >>= (liftX . maybeReplaceTarget) >> return (Endo id)

setReplaceTarget = withFocused $ XS.put . Target

getWindowWS a = withWindowSet $ \ws -> return $ listToMaybe
    [ w | w <- W.workspaces ws, has a (W.stack w) ]
    where has _ Nothing = False
          has _ (Just _) = True

replaceWindow original replacement =
  W.delete original . swapWindows original replacement

chromeReplaceKill =
  withFocused $ \w -> do
    vClass <- getClass w
    if vClass == "Chrome" then
      do
        replacement <-
          runMaybeT $ do
            ws <- MaybeT $ join . fmap W.stack <$> getWindowWS w
            MaybeT $
              listToMaybe <$>
              (intersect <$> minimizedWindows <*> windowsWithSameClass w ws)
        let doReplace rep = do
              maximizeWindow rep
              windows $ replaceWindow w rep
        maybe kill doReplace replacement
    else
      kill

-- Gather windows of same class

allWindows = concat <$> mapWorkspaces (return . W.integrate' . W.stack)

windowsMatchingClass klass =
  allWindows >>= filterM (((== klass) <$>) . getClass)

gatherClass klass = restoreFocus $
  windowsMatchingClass klass >>= mapM_ doBringWindow

gatherThisClass = thisClass >>= flip whenJust gatherClass

-- Window switching

-- Use greedyView to switch to the correct workspace, and then focus on the
-- appropriate window within that workspace.
greedyFocusWindow w ws =
  W.focusWindow w $
  W.greedyView (fromMaybe (W.currentTag ws) $ W.findTag w ws) ws

shiftThenView i = W.greedyView i . W.shift i

greedyBringWindow w = greedyFocusWindow w . bringWindow w

shiftToEmptyAndView =
  doTo Next EmptyWS DWO.getSortByOrder (windows . shiftThenView)

setFocusedScreen :: ScreenId -> WindowSet -> WindowSet
setFocusedScreen to ws =
  maybe ws (`setFocusedScreen'` ws) $ find ((to ==) . W.screen) (W.visible ws)

setFocusedScreen' to ws @ W.StackSet
  { W.current = prevCurr
  , W.visible = visible
  } = ws { W.current = to
         , W.visible = prevCurr:deleteBy screenEq to visible
         }

  where screenEq a b = W.screen a == W.screen b

nextScreen ws @ W.StackSet { W.visible = visible } =
  case visible of
    next:_ -> setFocusedScreen (W.screen next) ws
    _ -> ws

viewOtherScreen ws = W.greedyView ws . nextScreen

shiftThenViewOtherScreen ws w = viewOtherScreen ws . W.shiftWin ws w

shiftCurrentToWSOnOtherScreen ws s =
  fromMaybe s (flip (shiftThenViewOtherScreen ws) s <$> W.peek s)

shiftToEmptyNextScreen =
  doTo Next EmptyWS DWO.getSortByOrder $ windows . shiftCurrentToWSOnOtherScreen

swapFocusedWith w ws = W.modify' (swapFocusedWith' w) (W.delete' w ws)

swapFocusedWith' w (W.Stack current ls rs) = W.Stack w ls (rs ++ [current])

swapMinimizeStateAfter action =
  withFocused $ \originalWindow -> do
    _ <- action
    restoreFocus $ do
      maybeUnminimizeFocused
      withFocused $ \newWindow ->
        when (newWindow /= originalWindow) $ minimizeWindow originalWindow

-- Named Scratchpads

scratchpads =
  [ NS "htop" htopCommand (title =? "htop") nonFloating
  , NS "spotify" spotifyCommand spotifySelector nonFloating
  , NS "hangouts" hangoutsCommand hangoutsSelector nonFloating
  , NS "volume" volumeCommand volumeSelector nonFloating
  ]

-- TODO: This doesnt work well with minimized windows
doScratchpad =
  maybeUnminimizeAfter . deactivateFullAnd . namedScratchpadAction scratchpads

-- Raise or spawn

myRaiseNextMaybe =
  ((deactivateFullAnd . maybeUnminimizeAfter) .) .
  raiseNextMaybeCustomFocus greedyFocusWindow

myBringNextMaybe =
  ((deactivateFullAnd . maybeUnminimizeAfter) .) .
  raiseNextMaybeCustomFocus greedyBringWindow

bindBringAndRaise :: KeyMask
                  -> KeySym
                  -> X ()
                  -> Query Bool
                  -> [((KeyMask, KeySym), X ())]
bindBringAndRaise mask sym start query =
    [ ((mask, sym), doRaiseNext)
    , ((mask .|. controlMask, sym), myBringNextMaybe start query)
    , ((mask .|. shiftMask, sym), doRaiseNext)
    ]
  where doRaiseNext = myRaiseNextMaybe start query

bindBringAndRaiseMany :: [(KeyMask, KeySym, X (), Query Bool)]
                      -> [((KeyMask, KeySym), X ())]
bindBringAndRaiseMany = concatMap (\(a, b, c, d) -> bindBringAndRaise a b c d)

-- Screen shift

shiftToNextScreen ws =
  case W.visible ws of
    W.Screen i _ _:_ -> W.view (W.tag i) $ W.shift (W.tag i) ws
    _ -> ws

shiftToNextScreenX = windows shiftToNextScreen

getNextScreen ws =
  minimumBy compareScreen candidates
    where currentId = W.screen $ W.current ws
          otherScreens = W.visible ws
          largerId = filter ((> currentId) . W.screen) otherScreens
          compareScreen a b = compare (W.screen a) (W.screen b)
          candidates =
            case largerId of
              [] -> W.current ws:otherScreens -- Ensure a value will be selected
              _ -> largerId

goToNextScreen ws =
  if screenEq nScreen currScreen then ws
     else ws { W.current = nScreen
             , W.visible = currScreen : trimmedVisible
             }
  where
    currScreen = W.current ws
    nScreen = getNextScreen ws
    screenEq a b = W.screen a == W.screen b
    trimmedVisible =
      filter (not . screenEq nScreen) $ W.visible ws

goToNextScreenX = windows goToNextScreen

-- Key bindings

volumeUp = spawn "set_volume.sh --unmute --change-volume +5"
volumeDown = spawn "set_volume.sh --unmute --change-volume -5"
mute = spawn "set_volume.sh --toggle-mute"

shiftToEmptyOnScreen direction =
  followingWindow (windowToScreen direction True) >> shiftToEmptyAndView

addKeys conf@XConfig { modMask = modm } =

    -- Specific program spawning
    bindBringAndRaiseMany
    [ (modalt, xK_c, spawn chromeCommand, chromeSelector)
    , (modalt, xK_e, spawn emacsCommand, emacsSelector)
    , (modalt, xK_g, spawn gmailCommand, gmailSelector)
    , (modalt, xK_t, spawn transmissionCommand, transmissionSelector)
    ] ++

    -- ScratchPads
    [ ((modalt, xK_m), doScratchpad "htop")
    , ((modalt, xK_v), doScratchpad "volume")
    , ((modalt, xK_h), doScratchpad "hangouts")
    , ((modalt, xK_s), doScratchpad "spotify")
    , ((modalt .|. controlMask, xK_h),
       myRaiseNextMaybe (spawn hangoutsCommand) hangoutsSelector)
    , ((modalt .|. controlMask, xK_s),
       myRaiseNextMaybe (spawn spotifyCommand) spotifySelector)

    -- Specific program spawning

    , ((modm, xK_p), spawn "rofi -show drun -show-icons")
    , ((modm .|. shiftMask, xK_p), spawn "rofi -show run")

    -- Window manipulation

    , ((modm, xK_g), myGoToWindow)
    , ((modm, xK_b), myBringWindow)
    , ((modm .|. shiftMask, xK_b), myReplaceWindow)
    , ((modm .|. controlMask, xK_space), deactivateFullOr goFullscreen)
    , ((modm, xK_m), withFocused minimizeWindow)
    , ((modm .|. shiftMask, xK_m),
       deactivateFullOr $ withLastMinimized maximizeWindowAndFocus)
    , ((modm, xK_x), addHiddenWorkspace "NSP" >> windows (W.shift "NSP"))
    , ((modalt, xK_space), deactivateFullOr restoreOrMinimizeOtherClasses)
    , ((modalt, xK_Return), deactivateFullAnd restoreAllMinimized)
    , ((modm .|. controlMask, xK_t),
       setReplaceTarget >> spawn "chromix-too open chrome://newtab")
    , ((modm .|. controlMask, xK_c), chromeReplaceKill)
    , ((hyper, xK_g), gatherThisClass)

    -- Directional navigation
    , ((modm, xK_w), windowGo U True)
    , ((modm, xK_s), windowGo D True)
    , ((modm, xK_a), windowGo L True)
    , ((modm, xK_d), windowGo R True)

    , ((modm .|. shiftMask, xK_w), windowSwap U True)
    , ((modm .|. shiftMask, xK_s), windowSwap D True)
    , ((modm .|. shiftMask, xK_a), windowSwap L True)
    , ((modm .|. shiftMask, xK_d), windowSwap R True)

    , ((modm .|. controlMask, xK_w), followingWindow $ windowToScreen U True)
    , ((modm .|. controlMask, xK_s), followingWindow $ windowToScreen D True)
    , ((modm .|. controlMask, xK_a), followingWindow $ windowToScreen L True)
    , ((modm .|. controlMask, xK_d), followingWindow $ windowToScreen R True)

    , ((hyper, xK_w), screenGo U True)
    , ((hyper, xK_s), screenGo D True)
    , ((hyper, xK_a), screenGo L True)
    , ((hyper, xK_d), screenGo R True)

    , ((hyper .|. shiftMask, xK_w), followingWindow $ screenSwap U True)
    , ((hyper .|. shiftMask, xK_s), followingWindow $ screenSwap D True)
    , ((hyper .|. shiftMask, xK_a), followingWindow $ screenSwap L True)
    , ((hyper .|. shiftMask, xK_d), followingWindow $ screenSwap R True)

    , ((hyper .|. controlMask, xK_w), shiftToEmptyOnScreen U)
    , ((hyper .|. controlMask, xK_s), shiftToEmptyOnScreen D)
    , ((hyper .|. controlMask, xK_a), shiftToEmptyOnScreen L)
    , ((hyper .|. controlMask, xK_d), shiftToEmptyOnScreen R)

    -- Focus/Layout manipulation

    , ((modm, xK_e), goToNextScreenX)
    , ((modm, xK_slash), sendMessage $ Toggle MIRROR)
    , ((modm, xK_backslash),
       cycleWorkspaceOnCurrentScreen [xK_Super_L] xK_backslash xK_slash)
    , ((modm, xK_space), deactivateFullOr $ sendMessage NextLayout)
    , ((modm, xK_z), shiftToNextScreenX)
    , ((modm .|. shiftMask, xK_z), shiftToEmptyNextScreen)
    , ((modm .|. shiftMask, xK_h), shiftToEmptyAndView)
    , ((hyper, xK_5), getWorkspaceDmenu >>= windows . SW.swapWithCurrent)

    -- These need to be rebound to support boringWindows
    , ((modm, xK_m), focusMaster)
    , ((modm, xK_Tab), focusNextClass)
    , ((hyper, xK_e), moveTo Next EmptyWS)

    -- Miscellaneous XMonad

    , ((hyper, xK_1), toggleFadingForActiveWindow)
    , ((hyper .|. shiftMask, xK_1), toggleFadingForActiveWorkspace)
    , ((hyper .|. controlMask, xK_1), toggleFadingForActiveScreen)
    , ((hyper, xK_t), selectToggle)
    , ((modalt, xK_4), selectLimit)
    , ((hyper, xK_3), addWorkspacePrompt def)
    , ((modalt, xK_3), selectWorkspace def)
    , ((hyper .|. mod1Mask, xK_3), removeWorkspace)
    , ((hyper .|. mod1Mask, xK_r), renameWorkspace def)

    -- Non-XMonad

    , ((modm, xK_v), spawn "xclip -o | xdotool type --file -")
    , ((modm .|. controlMask, xK_s), spawn "split_current_chrome_tab.sh")
    , ((hyper, xK_v), spawn "rofi_clipit.sh")
    , ((hyper, xK_p), spawn "rofi-pass")
    , ((hyper, xK_h), spawn "screenshot.sh")
    , ((hyper, xK_c), spawn "shell_command.sh")
    , ((hyper, xK_x), spawn "rofi_command.sh")
    , ((hyper .|. shiftMask, xK_l), spawn "dm-tool lock")
    , ((hyper, xK_l), selectLayout)
    , ((hyper, xK_k), spawn "rofi_kill_process.sh")
    , ((hyper .|. shiftMask, xK_k),
       spawn "rofi_kill_all.sh")
    , ((hyper, xK_r), spawn "rofi-systemd")
    , ((hyper, xK_0), spawn "tvpower.js")
    , ((modalt, xK_z), spawn "split_chrome_tab_to_next_screen.sh")
    , ((hyper, xK_9), spawn "start_synergy.sh")
    , ((hyper, xK_slash), spawn "toggle_taffybar.sh")
    , ((hyper, xK_space), spawn "skippy-xd")
    , ((hyper, xK_i), spawn "rofi_select_input.hs")
    , ((hyper, xK_o), spawn "rofi_paswitch.sh")
    , ((modm, xK_apostrophe), spawn "load_default_map.sh")
    , ((modalt, xK_apostrophe), spawn "load_xkb_map.sh")

    -- Media keys

    -- playerctl
    , ((modm, xK_semicolon), spawn "playerctl play-pause")
    , ((0, xF86XK_AudioPause), spawn "playerctl play-pause")
    , ((0, xF86XK_AudioPlay), spawn "playerctl play-pause")
    , ((modm, xK_l), spawn "playerctl next")
    , ((0, xF86XK_AudioNext), spawn "playerctl next")
    , ((modm, xK_j), spawn "playerctl previous")
    , ((0, xF86XK_AudioPrev), spawn "playerctl previous")

    -- Volume control
    , ((0, xF86XK_AudioRaiseVolume), volumeUp)
    , ((0, xF86XK_AudioLowerVolume), volumeDown)
    , ((0, xF86XK_AudioMute), mute)
    , ((modm, xK_i), volumeUp)
    , ((modm, xK_k), volumeDown)
    , ((modm, xK_u), mute)
    , ((hyper .|. shiftMask, xK_q), spawn "toggle_mute_current_window.sh")
    , ((hctrl, xK_q), spawn "toggle_mute_current_window.sh only")

    , ((0, xF86XK_MonBrightnessUp), spawn "brightness.sh 5")
    , ((0, xF86XK_MonBrightnessDown), spawn "brightness.sh -5")

    ] ++

    -- Replace moving bindings

    [((additionalMask .|. modm, key), windows $ function workspace)
         | (workspace, key) <- zip (workspaces conf) [xK_1 .. xK_9]
         , (function, additionalMask) <-
             [ (W.greedyView, 0)
             , (W.shift, shiftMask)
             , (shiftThenView, controlMask)
             ]
    ]
    where
      modalt = modm .|. mod1Mask
      hyper = mod3Mask
      hctrl = hyper .|. controlMask

-- Local Variables:
-- flycheck-ghc-args: ("-Wno-missing-signatures")
-- haskell-indent-offset: 2
-- End: