xmonad-contrib/XMonad/Layout/OnHost.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.OnHost
-- Copyright   :  (c) Brandon S Allbery, Brent Yorgey
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  <allbery.b@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Configure layouts on a per-host basis: use layouts and apply
-- layout modifiers selectively, depending on the host.  Heavily based on
-- "XMonad.Layout.PerWorkspace" by Brent Yorgey.
-----------------------------------------------------------------------------

module XMonad.Layout.OnHost (-- * Usage
                             -- $usage
                             OnHost
                            ,onHost
                            ,onHosts
                            ,modHost
                            ,modHosts
                            ) where

import           XMonad
import qualified XMonad.StackSet              as W

import           XMonad.Layout.LayoutModifier

import           Data.Maybe                        (fromMaybe)
import           System.Posix.Env                  (getEnv)

-- $usage
-- You can use this module by importing it into your ~\/.xmonad\/xmonad.hs file:
--
-- > import XMonad.Layout.OnHost
--
-- and modifying your 'layoutHook' as follows (for example):
--
-- > layoutHook = modHost "baz" m1 $            -- apply layout modifier m1 to all layouts on host "baz"
-- >              onHost "foo" l1 $             -- layout l1 will be used on host "foo".
-- >              onHosts ["bar","quux"] l2 $   -- layout l2 will be used on hosts "bar" and "quux".
-- >              l3                            -- layout l3 will be used on all other hosts.
--
-- Note that @l1@, @l2@, and @l3@ can be arbitrarily complicated
-- layouts, e.g. @(Full ||| smartBorders $ tabbed shrinkText
-- defaultTConf ||| ...)@, and @m1@ can be any layout modifier, i.e. a
-- function of type @(l a -> ModifiedLayout lm l a)@.
--
-- In another scenario, suppose you wanted to have layouts A, B, and C
-- available on all hosts, except that on host foo you want
-- layout D instead of C.  You could do that as follows:
--
-- > layoutHook = A ||| B ||| onHost "foo" D C
--
-- Note that we rely on '$HOST' being set in the environment, as is true on most
-- modern systems; if it's not, you may want to use a wrapper around xmonad or
-- perhaps use 'System.Posix.Env.setEnv' (or 'putEnv') to set it in 'main'.
-- This is to avoid dragging in the network package as an xmonad dependency.
-- If '$HOST' is not defined, it will behave as if the host name never matches.
--
-- Also note that '$HOST' is usually a fully qualified domain name, not a short name.
-- If you use a short name, this code will try to truncate $HOST to match; this may
-- prove too magical, though, and may change in the future.

-- | Specify one layout to use on a particular host, and another
--   to use on all others.  The second layout can be another call to
--   'onHost', and so on.
onHost :: (LayoutClass l1 a, LayoutClass l2 a)
       => String -- ^ the name of the host to match
       -> (l1 a) -- ^ layout to use on the matched host
       -> (l2 a) -- ^ layout to use everywhere else
       -> OnHost l1 l2 a
onHost host = onHosts [host]

-- | Specify one layout to use on a particular set of hosts, and
--   another to use on all other hosts.
onHosts :: (LayoutClass l1 a, LayoutClass l2 a)
        => [String] -- ^ names of hosts to match
        -> (l1 a)   -- ^ layout to use on matched hosts
        -> (l2 a)   -- ^ layout to use everywhere else
        -> OnHost l1 l2 a
onHosts hosts l1 l2 = OnHost hosts False l1 l2

-- | Specify a layout modifier to apply on a particular host; layouts
--   on all other hosts will remain unmodified.
modHost :: (LayoutClass l a)
        => String                          -- ^ name of the host to match
        -> (l a -> ModifiedLayout lm l a)  -- ^ the modifier to apply on the matching host
        -> l a                             -- ^ the base layout
        -> OnHost (ModifiedLayout lm l) l a
modHost host = modHosts [host]

-- | Specify a layout modifier to apply on a particular set of
--   hosts; layouts on all other hosts will remain
--   unmodified.
modHosts :: (LayoutClass l a)
         => [String]                        -- ^ names of the hosts to match
         -> (l a -> ModifiedLayout lm l a)  -- ^ the modifier to apply on the matching hosts
         -> l a                             -- ^ the base layout
         -> OnHost (ModifiedLayout lm l) l a
modHosts hosts f l = OnHost hosts False (f l) l

-- | Structure for representing a host-specific layout along with
--   a layout for all other hosts. We store the names of hosts
--   to be matched, and the two layouts. We save the layout choice in
--   the Bool, to be used to implement description.
data OnHost l1 l2 a = OnHost [String]
                             Bool
                             (l1 a)
                             (l2 a)
    deriving (Read, Show)

instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (OnHost l1 l2) a where
    runLayout (W.Workspace i p@(OnHost hosts _ lt lf) ms) r = do
      h <- io $ getEnv "HOST"
      if maybe False (`elemFQDN` hosts) h
        then do (wrs, mlt') <- runLayout (W.Workspace i lt ms) r
                return (wrs, Just $ mkNewOnHostT p mlt')
        else do (wrs, mlt') <- runLayout (W.Workspace i lf ms) r
                return (wrs, Just $ mkNewOnHostF p mlt')

    handleMessage (OnHost hosts bool lt lf) m
        | bool      = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ OnHost hosts bool nt lf)
        | otherwise = handleMessage lf m >>= maybe (return Nothing) (\nf -> return . Just $ OnHost hosts bool lt nf)

    description (OnHost _ True  l1 _) = description l1
    description (OnHost _ _     _ l2) = description l2

-- | Construct new OnHost values with possibly modified layouts.
mkNewOnHostT :: OnHost l1 l2 a -> Maybe (l1 a) -> OnHost l1 l2 a
mkNewOnHostT (OnHost hosts _ lt lf) mlt' =
  (\lt' -> OnHost hosts True lt' lf) $ fromMaybe lt mlt'

mkNewOnHostF :: OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a
mkNewOnHostF (OnHost hosts _ lt lf) mlf' =
  (\lf' -> OnHost hosts False lt lf') $ fromMaybe lf mlf'

-- | 'Data.List.elem' except that if one side has a dot and the other doesn't, we truncate
--   the one that does at the dot.
elemFQDN           :: String -> [String] -> Bool
elemFQDN _  []     =  False
elemFQDN h0 (h:hs)
  | h0 `eqFQDN` h  =  True
  | otherwise      =  elemFQDN h0 hs

-- | String equality, possibly truncating one side at a dot.
eqFQDN :: String -> String -> Bool
eqFQDN a b
  | '.' `elem` a && '.' `elem` b =                    a ==                    b
  | '.' `elem` a                 = takeWhile (/= '.') a ==                    b
  |                 '.' `elem` b =                    a == takeWhile (/= '.') b
  | otherwise                    =                    a ==                    b