XMonad.Layout.OnHost allows host-specific modifications to a layout, which

Ignore-this: 4c0d5580e805ff9f40918308914f3bf9
is otherwise very difficult to do.  Similarly to X.L.PerWorkspace, it provides
onHost, onHosts, modHost, and modHosts layout modifiers.  It attempts to do
smart hostname comparison, such that short names will be matched with short
names and FQDNs with FQDNs.

This module currently requires that $HOST be set in the environment.
You can use System.Posix.Env.setEnv to do so in xmonad.hs if need be.
(Properly, this should be done via the network library, but I'm trying to
avoid adding that dependency.)  An alternative would be to shell out to
get the name, but that has considerable portability hurdles.

darcs-hash:20120320030912-181ff-ac823f07d94265c3e745e623f6da79eeead4d121.gz

1 files changed, 155 insertions, 0 deletions

diff --git a/XMonad/Layout/OnHost.hs b/XMonad/Layout/OnHost.hs
new file mode 100644
index 0000000..e14a24c
--- /dev/null
+++ b/XMonad/Layout/OnHost.hs
@@ -0,0 +1,155 @@
+{-# 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