{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.PerWorkspace
-- Description :  Use layouts and apply layout modifiers selectively.
-- Copyright   :  (c) Brent Yorgey
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  <byorgey@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Configure layouts on a per-workspace basis: use layouts and apply
-- layout modifiers selectively, depending on the workspace.
-----------------------------------------------------------------------------

module XMonad.Layout.PerWorkspace
    ( -- * Usage
      -- $usage
      PerWorkspace,
      onWorkspace, onWorkspaces,
      modWorkspace, modWorkspaces
    ) where

import XMonad
import qualified XMonad.StackSet as W

import XMonad.Prelude (fromMaybe)

-- $usage
-- You can use this module by importing it into your @xmonad.hs@ file:
--
-- > import XMonad.Layout.PerWorkspace
--
-- and modifying your layoutHook as follows (for example):
--
-- > layoutHook = modWorkspace "baz" m1 $  -- apply layout modifier m1 to all layouts on workspace "baz"
-- >              onWorkspace "foo" l1 $  -- layout l1 will be used on workspace "foo".
-- >              onWorkspaces ["bar","6"] l2 $  -- layout l2 will be used on workspaces "bar" and "6".
-- >              l3                      -- layout l3 will be used on all other workspaces.
--
-- 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 fact, @m1@ can be any
-- function @(LayoutClass l a, LayoutClass l' a) => l a -> l' a@.)
--
-- In another scenario, suppose you wanted to have layouts A, B, and C
-- available on all workspaces, except that on workspace foo you want
-- layout D instead of C.  You could do that as follows:
--
-- > layoutHook = A ||| B ||| onWorkspace "foo" D C

-- | Specify one layout to use on a particular workspace, and another
--   to use on all others.  The second layout can be another call to
--   'onWorkspace', and so on.
onWorkspace :: (LayoutClass l1 a, LayoutClass l2 a)
               => WorkspaceId -- ^ the tag of the workspace to match
               -> l1 a        -- ^ layout to use on the matched workspace
               -> l2 a        -- ^ layout to use everywhere else
               -> PerWorkspace l1 l2 a
onWorkspace :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
WorkspaceId -> l1 a -> l2 a -> PerWorkspace l1 l2 a
onWorkspace WorkspaceId
wsId = forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[WorkspaceId] -> l1 a -> l2 a -> PerWorkspace l1 l2 a
onWorkspaces [WorkspaceId
wsId]

-- | Specify one layout to use on a particular set of workspaces, and
--   another to use on all other workspaces.
onWorkspaces :: (LayoutClass l1 a, LayoutClass l2 a)
                => [WorkspaceId]  -- ^ tags of workspaces to match
                -> l1 a           -- ^ layout to use on matched workspaces
                -> l2 a           -- ^ layout to use everywhere else
                -> PerWorkspace l1 l2 a
onWorkspaces :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[WorkspaceId] -> l1 a -> l2 a -> PerWorkspace l1 l2 a
onWorkspaces [WorkspaceId]
wsIds = forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[WorkspaceId] -> (l2 a -> l1 a) -> l2 a -> PerWorkspace l1 l2 a
modWorkspaces [WorkspaceId]
wsIds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Specify a layout modifier to apply to a particular workspace; layouts
--   on all other workspaces will remain unmodified.
modWorkspace :: (LayoutClass l1 a, LayoutClass l2 a)
             => WorkspaceId    -- ^ tag of the workspace to match
             -> (l2 a -> l1 a)  -- ^ the modifier to apply on the matching workspace
             -> l2 a           -- ^ the base layout
             -> PerWorkspace l1 l2 a
modWorkspace :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
WorkspaceId -> (l2 a -> l1 a) -> l2 a -> PerWorkspace l1 l2 a
modWorkspace WorkspaceId
wsId = forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[WorkspaceId] -> (l2 a -> l1 a) -> l2 a -> PerWorkspace l1 l2 a
modWorkspaces [WorkspaceId
wsId]

-- | Specify a layout modifier to apply to a particular set of
--   workspaces; layouts on all other workspaces will remain
--   unmodified.
modWorkspaces :: (LayoutClass l1 a, LayoutClass l2 a)
              => [WorkspaceId] -- ^ tags of the workspaces to match
              -> (l2 a -> l1 a) -- ^ the modifier to apply on the matching workspaces
              -> l2 a          -- ^ the base layout
              -> PerWorkspace l1 l2 a
modWorkspaces :: forall (l1 :: * -> *) a (l2 :: * -> *).
(LayoutClass l1 a, LayoutClass l2 a) =>
[WorkspaceId] -> (l2 a -> l1 a) -> l2 a -> PerWorkspace l1 l2 a
modWorkspaces [WorkspaceId]
wsIds l2 a -> l1 a
f l2 a
l = forall (l1 :: * -> *) (l2 :: * -> *) a.
[WorkspaceId] -> Bool -> l1 a -> l2 a -> PerWorkspace l1 l2 a
PerWorkspace [WorkspaceId]
wsIds Bool
False (l2 a -> l1 a
f l2 a
l) l2 a
l

-- | Structure for representing a workspace-specific layout along with
-- a layout for all other workspaces. We store the tags of workspaces
-- to be matched, and the two layouts. We save the layout choice in
-- the Bool, to be used to implement description.
data PerWorkspace l1 l2 a = PerWorkspace [WorkspaceId]
                                         Bool
                                         (l1 a)
                                         (l2 a)
    deriving (ReadPrec [PerWorkspace l1 l2 a]
ReadPrec (PerWorkspace l1 l2 a)
ReadS [PerWorkspace 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 [PerWorkspace l1 l2 a]
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec (PerWorkspace l1 l2 a)
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
Int -> ReadS (PerWorkspace l1 l2 a)
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadS [PerWorkspace l1 l2 a]
readListPrec :: ReadPrec [PerWorkspace l1 l2 a]
$creadListPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec [PerWorkspace l1 l2 a]
readPrec :: ReadPrec (PerWorkspace l1 l2 a)
$creadPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadPrec (PerWorkspace l1 l2 a)
readList :: ReadS [PerWorkspace l1 l2 a]
$creadList :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
ReadS [PerWorkspace l1 l2 a]
readsPrec :: Int -> ReadS (PerWorkspace l1 l2 a)
$creadsPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Read (l1 a), Read (l2 a)) =>
Int -> ReadS (PerWorkspace l1 l2 a)
Read, Int -> PerWorkspace l1 l2 a -> ShowS
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
Int -> PerWorkspace l1 l2 a -> ShowS
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
[PerWorkspace l1 l2 a] -> ShowS
forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
PerWorkspace l1 l2 a -> WorkspaceId
showList :: [PerWorkspace l1 l2 a] -> ShowS
$cshowList :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
[PerWorkspace l1 l2 a] -> ShowS
show :: PerWorkspace l1 l2 a -> WorkspaceId
$cshow :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
PerWorkspace l1 l2 a -> WorkspaceId
showsPrec :: Int -> PerWorkspace l1 l2 a -> ShowS
$cshowsPrec :: forall (l1 :: * -> *) (l2 :: * -> *) a.
(Show (l1 a), Show (l2 a)) =>
Int -> PerWorkspace l1 l2 a -> ShowS
Show)

instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (PerWorkspace l1 l2) a where
    runLayout :: Workspace WorkspaceId (PerWorkspace l1 l2 a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (PerWorkspace l1 l2 a))
runLayout (W.Workspace WorkspaceId
i p :: PerWorkspace l1 l2 a
p@(PerWorkspace [WorkspaceId]
wsIds Bool
_ l1 a
lt l2 a
lf) Maybe (Stack a)
ms) Rectangle
r
        | WorkspaceId
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
wsIds = do ([(a, Rectangle)]
wrs, Maybe (l1 a)
mlt') <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
W.Workspace WorkspaceId
i l1 a
lt Maybe (Stack a)
ms) Rectangle
r
                              forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (l1 :: * -> *) (l2 :: * -> *) a.
PerWorkspace l1 l2 a -> Maybe (l1 a) -> PerWorkspace l1 l2 a
mkNewPerWorkspaceT PerWorkspace l1 l2 a
p Maybe (l1 a)
mlt')
        | Bool
otherwise      = do ([(a, Rectangle)]
wrs, Maybe (l2 a)
mlt') <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
W.Workspace WorkspaceId
i l2 a
lf Maybe (Stack a)
ms) Rectangle
r
                              forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (l1 :: * -> *) (l2 :: * -> *) a.
PerWorkspace l1 l2 a -> Maybe (l2 a) -> PerWorkspace l1 l2 a
mkNewPerWorkspaceF PerWorkspace l1 l2 a
p Maybe (l2 a)
mlt')

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

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

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

mkNewPerWorkspaceF :: PerWorkspace l1 l2 a -> Maybe (l2 a) ->
                      PerWorkspace l1 l2 a
mkNewPerWorkspaceF :: forall (l1 :: * -> *) (l2 :: * -> *) a.
PerWorkspace l1 l2 a -> Maybe (l2 a) -> PerWorkspace l1 l2 a
mkNewPerWorkspaceF (PerWorkspace [WorkspaceId]
wsIds Bool
_ l1 a
lt l2 a
lf) Maybe (l2 a)
mlf' =
    forall (l1 :: * -> *) (l2 :: * -> *) a.
[WorkspaceId] -> Bool -> l1 a -> l2 a -> PerWorkspace l1 l2 a
PerWorkspace [WorkspaceId]
wsIds Bool
False l1 a
lt forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe l2 a
lf Maybe (l2 a)
mlf'