{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.OnHost
-- Description :  Use layouts and apply layout modifiers selectively, depending on the host.
-- 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
-- def ||| ...)@, 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 :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
String -> l1 a -> l2 a -> OnHost l1 l2 a
onHost String
host = [String] -> l1 a -> l2 a -> OnHost l1 l2 a
forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[String] -> l1 a -> l2 a -> OnHost l1 l2 a
onHosts [String
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 :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[String] -> l1 a -> l2 a -> OnHost l1 l2 a
onHosts [String]
hosts = [String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
[String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
OnHost [String]
hosts Bool
False

-- | 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 :: forall (l :: * -> *) a (lm :: * -> *).
LayoutClass l a =>
String
-> (l a -> ModifiedLayout lm l a)
-> l a
-> OnHost (ModifiedLayout lm l) l a
modHost String
host = [String]
-> (l a -> ModifiedLayout lm l a)
-> l a
-> OnHost (ModifiedLayout lm l) l a
forall (l :: * -> *) a (lm :: * -> *).
LayoutClass l a =>
[String]
-> (l a -> ModifiedLayout lm l a)
-> l a
-> OnHost (ModifiedLayout lm l) l a
modHosts [String
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 :: forall (l :: * -> *) a (lm :: * -> *).
LayoutClass l a =>
[String]
-> (l a -> ModifiedLayout lm l a)
-> l a
-> OnHost (ModifiedLayout lm l) l a
modHosts [String]
hosts l a -> ModifiedLayout lm l a
f l a
l = [String]
-> Bool
-> ModifiedLayout lm l a
-> l a
-> OnHost (ModifiedLayout lm l) l a
forall (l1 :: * -> *) (l2 :: * -> *) a.
[String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
OnHost [String]
hosts Bool
False (l a -> ModifiedLayout lm l a
f l a
l) l a
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 (ReadPrec [OnHost l1 l2 a]
ReadPrec (OnHost l1 l2 a)
Int -> ReadS (OnHost l1 l2 a)
ReadS [OnHost l1 l2 a]
(Int -> ReadS (OnHost l1 l2 a))
-> ReadS [OnHost l1 l2 a]
-> ReadPrec (OnHost l1 l2 a)
-> ReadPrec [OnHost l1 l2 a]
-> Read (OnHost l1 l2 a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec [OnHost l1 l2 a]
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec (OnHost l1 l2 a)
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
Int -> ReadS (OnHost l1 l2 a)
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadS [OnHost l1 l2 a]
readListPrec :: ReadPrec [OnHost l1 l2 a]
$creadListPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec [OnHost l1 l2 a]
readPrec :: ReadPrec (OnHost l1 l2 a)
$creadPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec (OnHost l1 l2 a)
readList :: ReadS [OnHost l1 l2 a]
$creadList :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadS [OnHost l1 l2 a]
readsPrec :: Int -> ReadS (OnHost l1 l2 a)
$creadsPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
Int -> ReadS (OnHost l1 l2 a)
Read, Int -> OnHost l1 l2 a -> ShowS
[OnHost l1 l2 a] -> ShowS
OnHost l1 l2 a -> String
(Int -> OnHost l1 l2 a -> ShowS)
-> (OnHost l1 l2 a -> String)
-> ([OnHost l1 l2 a] -> ShowS)
-> Show (OnHost l1 l2 a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
Int -> OnHost l1 l2 a -> ShowS
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
[OnHost l1 l2 a] -> ShowS
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
OnHost l1 l2 a -> String
showList :: [OnHost l1 l2 a] -> ShowS
$cshowList :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
[OnHost l1 l2 a] -> ShowS
show :: OnHost l1 l2 a -> String
$cshow :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
OnHost l1 l2 a -> String
showsPrec :: Int -> OnHost l1 l2 a -> ShowS
$cshowsPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
Int -> OnHost l1 l2 a -> ShowS
Show)

instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (OnHost l1 l2) a where
    runLayout :: Workspace String (OnHost l1 l2 a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (OnHost l1 l2 a))
runLayout (W.Workspace String
i p :: OnHost l1 l2 a
p@(OnHost [String]
hosts Bool
_ l1 a
lt l2 a
lf) Maybe (Stack a)
ms) Rectangle
r = do
      Maybe String
h <- IO (Maybe String) -> X (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe String) -> X (Maybe String))
-> IO (Maybe String) -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
getEnv String
"HOST"
      if Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> [String] -> Bool
`elemFQDN` [String]
hosts) Maybe String
h
        then do ([(a, Rectangle)]
wrs, Maybe (l1 a)
mlt') <- Workspace String (l1 a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (String -> l1 a -> Maybe (Stack a) -> Workspace String (l1 a) a
forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
W.Workspace String
i l1 a
lt Maybe (Stack a)
ms) Rectangle
r
                ([(a, Rectangle)], Maybe (OnHost l1 l2 a))
-> X ([(a, Rectangle)], Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a. a -> Maybe a
Just (OnHost l1 l2 a -> Maybe (OnHost l1 l2 a))
-> OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a b. (a -> b) -> a -> b
$ OnHost l1 l2 a -> Maybe (l1 a) -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
OnHost l1 l2 a -> Maybe (l1 a) -> OnHost l1 l2 a
mkNewOnHostT OnHost l1 l2 a
p Maybe (l1 a)
mlt')
        else do ([(a, Rectangle)]
wrs, Maybe (l2 a)
mlt') <- Workspace String (l2 a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (l2 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (String -> l2 a -> Maybe (Stack a) -> Workspace String (l2 a) a
forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
W.Workspace String
i l2 a
lf Maybe (Stack a)
ms) Rectangle
r
                ([(a, Rectangle)], Maybe (OnHost l1 l2 a))
-> X ([(a, Rectangle)], Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a. a -> Maybe a
Just (OnHost l1 l2 a -> Maybe (OnHost l1 l2 a))
-> OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a b. (a -> b) -> a -> b
$ OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a
mkNewOnHostF OnHost l1 l2 a
p Maybe (l2 a)
mlt')

    handleMessage :: OnHost l1 l2 a -> SomeMessage -> X (Maybe (OnHost l1 l2 a))
handleMessage (OnHost [String]
hosts Bool
bool l1 a
lt l2 a
lf) SomeMessage
m
        | Bool
bool      = l1 a -> SomeMessage -> X (Maybe (l1 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l1 a
lt SomeMessage
m X (Maybe (l1 a))
-> (Maybe (l1 a) -> X (Maybe (OnHost l1 l2 a)))
-> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X (Maybe (OnHost l1 l2 a))
-> (l1 a -> X (Maybe (OnHost l1 l2 a)))
-> Maybe (l1 a)
-> X (Maybe (OnHost l1 l2 a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OnHost l1 l2 a)
forall a. Maybe a
Nothing) (\l1 a
nt -> Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a)))
-> (OnHost l1 l2 a -> Maybe (OnHost l1 l2 a))
-> OnHost l1 l2 a
-> X (Maybe (OnHost l1 l2 a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a. a -> Maybe a
Just (OnHost l1 l2 a -> X (Maybe (OnHost l1 l2 a)))
-> OnHost l1 l2 a -> X (Maybe (OnHost l1 l2 a))
forall a b. (a -> b) -> a -> b
$ [String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
[String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
OnHost [String]
hosts Bool
bool l1 a
nt l2 a
lf)
        | Bool
otherwise = l2 a -> SomeMessage -> X (Maybe (l2 a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l2 a
lf SomeMessage
m X (Maybe (l2 a))
-> (Maybe (l2 a) -> X (Maybe (OnHost l1 l2 a)))
-> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= X (Maybe (OnHost l1 l2 a))
-> (l2 a -> X (Maybe (OnHost l1 l2 a)))
-> Maybe (l2 a)
-> X (Maybe (OnHost l1 l2 a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OnHost l1 l2 a)
forall a. Maybe a
Nothing) (Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OnHost l1 l2 a) -> X (Maybe (OnHost l1 l2 a)))
-> (l2 a -> Maybe (OnHost l1 l2 a))
-> l2 a
-> X (Maybe (OnHost l1 l2 a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnHost l1 l2 a -> Maybe (OnHost l1 l2 a)
forall a. a -> Maybe a
Just (OnHost l1 l2 a -> Maybe (OnHost l1 l2 a))
-> (l2 a -> OnHost l1 l2 a) -> l2 a -> Maybe (OnHost l1 l2 a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
[String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
OnHost [String]
hosts Bool
bool l1 a
lt)

    description :: OnHost l1 l2 a -> String
description (OnHost [String]
_ Bool
True  l1 a
l1 l2 a
_) = l1 a -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l1 a
l1
    description (OnHost [String]
_ Bool
_     l1 a
_ l2 a
l2) = l2 a -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l2 a
l2

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

mkNewOnHostF :: OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a
mkNewOnHostF :: forall (l1 :: * -> *) (l2 :: * -> *) a.
OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a
mkNewOnHostF (OnHost [String]
hosts Bool
_ l1 a
lt l2 a
lf) Maybe (l2 a)
mlf' =
  [String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
forall (l1 :: * -> *) (l2 :: * -> *) a.
[String] -> Bool -> l1 a -> l2 a -> OnHost l1 l2 a
OnHost [String]
hosts Bool
False l1 a
lt (l2 a -> OnHost l1 l2 a) -> l2 a -> OnHost l1 l2 a
forall a b. (a -> b) -> a -> b
$ l2 a -> Maybe (l2 a) -> l2 a
forall a. a -> Maybe a -> a
fromMaybe l2 a
lf Maybe (l2 a)
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 :: String -> [String] -> Bool
elemFQDN String
_  []     =  Bool
False
elemFQDN String
h0 (String
h:[String]
hs)
  | String
h0 String -> String -> Bool
`eqFQDN` String
h  =  Bool
True
  | Bool
otherwise      =  String -> [String] -> Bool
elemFQDN String
h0 [String]
hs

-- | String equality, possibly truncating one side at a dot.
eqFQDN :: String -> String -> Bool
eqFQDN :: String -> String -> Bool
eqFQDN String
a String
b
  | Char
'.' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
a Bool -> Bool -> Bool
&& Char
'.' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
b =                    String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==                    String
b
  | Char
'.' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
a                 = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==                    String
b
  |                 Char
'.' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
b =                    String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') String
b
  | Bool
otherwise                    =                    String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==                    String
b