{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
--------------------------------------------------------------------
-- |
-- Module      : XMonad.Layout.SideBorderDecoration
-- Description : Configure the border position around windows.
-- Copyright   : (c) 2018  L. S. Leary
--                   2022  Tony Zorman
-- License     : BSD3
-- Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>
--
-- This module allows for having a configurable border position around
-- windows; i.e., it can move the border to any cardinal direction.
--
--------------------------------------------------------------------
module XMonad.Layout.SideBorderDecoration (
  -- * Usage
  -- $usage
  sideBorder,

  -- * Border configuration
  SideBorderConfig (..),
  def,

  -- * Re-exports
  Direction2D (..),

  -- * Lower-level hooks
  sideBorderLayout,
) where

import qualified XMonad.StackSet as W

import XMonad
import XMonad.Layout.Decoration
import XMonad.StackSet (Stack)
import XMonad.Util.Types

{- $usage

To use this module, first import it into your configuration file:

> import XMonad.Layout.SideBorderDecoration

You can now add the 'sideBorder' combinator to your configuration:

> main :: IO ()
> main = xmonad
>      $ …
>      $ sideBorder mySideBorderConfig
>      $ def { … }
>  where
>   mySideBorderConfig :: SideBorderConfig
>   mySideBorderConfig = def
>     { sbSide          = D
>     , sbActiveColor   = "#ff0000"
>     , sbInactiveColor = "#ffaaaa"
>     , sbSize          = 5
>     }

or, alternatively,

> main :: IO ()
> main = xmonad
>      $ …
>      $ sideBorder def{ sbSide = D, sbActiveColor = "#ff000", … }
>      $ def { … }

See 'SideBorderConfig' for the different size and colour options.

The following is a fully-functional, minimal configuration example:

> import XMonad
> import XMonad.Layout.SideBorderDecoration
>
> main :: IO ()
> main = xmonad $ sideBorder def $ def

This would result in the following border being displayed:

<<https://user-images.githubusercontent.com/50166980/184537672-136f85a3-dfe7-42e2-b4c8-356d934d1bff.png>>

-}

-----------------------------------------------------------------------
-- Configuration

-- | Configuring how the border looks like.
data SideBorderConfig = SideBorderConfig
  { SideBorderConfig -> Direction2D
sbSide          :: !Direction2D  -- ^ Which side to have the border on.
  , SideBorderConfig -> String
sbActiveColor   :: !String       -- ^ Active border colour.
  , SideBorderConfig -> String
sbInactiveColor :: !String       -- ^ Inactive border colour.
  , SideBorderConfig -> Dimension
sbSize          :: !Dimension
    -- ^ Size of the border.  This will be the height if 'sbSide' is 'U'
    --   or 'D' and the width if it is 'L' or 'R'.
  }

instance Default SideBorderConfig where
  def :: SideBorderConfig
  def :: SideBorderConfig
def = SideBorderConfig
    { sbSide :: Direction2D
sbSide          = Direction2D
D
    , sbActiveColor :: String
sbActiveColor   = String
"#ff0000"
    , sbInactiveColor :: String
sbInactiveColor = String
"#ffaaaa"
    , sbSize :: Dimension
sbSize          = Dimension
5
    }

-----------------------------------------------------------------------
-- User-facing

-- | Move the default XMonad border to any of the four cardinal
-- directions.
--
-- Note that this function should only be applied once to your
-- configuration and should /not/ be combined with 'sideBorderLayout'.
sideBorder :: SideBorderConfig -> XConfig l -> XConfig (SideBorder l)
sideBorder :: forall (l :: * -> *).
SideBorderConfig -> XConfig l -> XConfig (SideBorder l)
sideBorder SideBorderConfig
sbc XConfig l
cfg =
  XConfig l
cfg{ layoutHook  = sideBorderLayout sbc (layoutHook cfg)
     , borderWidth = 0
     }

-- | Layout hook to only enable the side border for some layouts.  For
-- example:
--
-- > myLayout = Full ||| sideBorderLayout def tall ||| somethingElse
--
-- Note that, unlike 'sideBorder', this does /not/ disable the normal
-- border in XMonad, you will have to do this yourself.  Remove this
-- function from your layout hook and use 'sideBorder' if you want a
-- side border in every layout (do not use the two functions together).
sideBorderLayout :: Eq a => SideBorderConfig -> l a -> SideBorder l a
sideBorderLayout :: forall a (l :: * -> *).
Eq a =>
SideBorderConfig -> l a -> SideBorder l a
sideBorderLayout SideBorderConfig{ Direction2D
sbSide :: SideBorderConfig -> Direction2D
sbSide :: Direction2D
sbSide, String
sbActiveColor :: SideBorderConfig -> String
sbActiveColor :: String
sbActiveColor, String
sbInactiveColor :: SideBorderConfig -> String
sbInactiveColor :: String
sbInactiveColor, Dimension
sbSize :: SideBorderConfig -> Dimension
sbSize :: Dimension
sbSize } =
  BorderShrinker
-> Theme
-> SideBorderDecoration a
-> l a
-> ModifiedLayout
     (Decoration SideBorderDecoration BorderShrinker) l a
forall (ds :: * -> *) a s (l :: * -> *).
(DecorationStyle ds a, Shrinker s) =>
s -> Theme -> ds a -> l a -> ModifiedLayout (Decoration ds s) l a
decoration BorderShrinker
BorderShrinker Theme
theme (Direction2D -> SideBorderDecoration a
forall a. Direction2D -> SideBorderDecoration a
SideBorderDecoration Direction2D
sbSide)
 where
  theme :: Theme
  theme :: Theme
theme = Theme
deco
    { activeColor   = sbActiveColor
    , inactiveColor = sbInactiveColor
    }
   where
    deco :: Theme
deco | Direction2D
sbSide Direction2D -> [Direction2D] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Direction2D
U, Direction2D
D] = Theme
forall a. Default a => a
def{ decoHeight = sbSize }
         | Bool
otherwise            = Theme
forall a. Default a => a
def{ decoWidth  = sbSize }

-----------------------------------------------------------------------
-- Decoration

newtype SideBorderDecoration a = SideBorderDecoration Direction2D
  deriving (Int -> SideBorderDecoration a -> ShowS
[SideBorderDecoration a] -> ShowS
SideBorderDecoration a -> String
(Int -> SideBorderDecoration a -> ShowS)
-> (SideBorderDecoration a -> String)
-> ([SideBorderDecoration a] -> ShowS)
-> Show (SideBorderDecoration a)
forall a. Int -> SideBorderDecoration a -> ShowS
forall a. [SideBorderDecoration a] -> ShowS
forall a. SideBorderDecoration a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> SideBorderDecoration a -> ShowS
showsPrec :: Int -> SideBorderDecoration a -> ShowS
$cshow :: forall a. SideBorderDecoration a -> String
show :: SideBorderDecoration a -> String
$cshowList :: forall a. [SideBorderDecoration a] -> ShowS
showList :: [SideBorderDecoration a] -> ShowS
Show, ReadPrec [SideBorderDecoration a]
ReadPrec (SideBorderDecoration a)
Int -> ReadS (SideBorderDecoration a)
ReadS [SideBorderDecoration a]
(Int -> ReadS (SideBorderDecoration a))
-> ReadS [SideBorderDecoration a]
-> ReadPrec (SideBorderDecoration a)
-> ReadPrec [SideBorderDecoration a]
-> Read (SideBorderDecoration a)
forall a. ReadPrec [SideBorderDecoration a]
forall a. ReadPrec (SideBorderDecoration a)
forall a. Int -> ReadS (SideBorderDecoration a)
forall a. ReadS [SideBorderDecoration a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (SideBorderDecoration a)
readsPrec :: Int -> ReadS (SideBorderDecoration a)
$creadList :: forall a. ReadS [SideBorderDecoration a]
readList :: ReadS [SideBorderDecoration a]
$creadPrec :: forall a. ReadPrec (SideBorderDecoration a)
readPrec :: ReadPrec (SideBorderDecoration a)
$creadListPrec :: forall a. ReadPrec [SideBorderDecoration a]
readListPrec :: ReadPrec [SideBorderDecoration a]
Read)

type SideBorder = ModifiedLayout (Decoration SideBorderDecoration BorderShrinker)

instance Eq a => DecorationStyle SideBorderDecoration a where
  shrink :: SideBorderDecoration a -> Rectangle -> Rectangle -> Rectangle
  shrink :: SideBorderDecoration a -> Rectangle -> Rectangle -> Rectangle
shrink SideBorderDecoration a
dec (Rectangle Position
_ Position
_ Dimension
dw Dimension
dh) (Rectangle Position
x Position
y Dimension
w Dimension
h) = case SideBorderDecoration a
dec of
    SideBorderDecoration Direction2D
U -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x           (Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
dh) Dimension
w        (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dh)
    SideBorderDecoration Direction2D
R -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x           Position
y           (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dw) Dimension
h
    SideBorderDecoration Direction2D
D -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x           Position
y           Dimension
w        (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dh)
    SideBorderDecoration Direction2D
L -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
dw) Position
y           (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dw) Dimension
h

  pureDecoration
    :: SideBorderDecoration a
    -> Dimension -> Dimension
    -> Rectangle
    -> Stack a
    -> [(a, Rectangle)]
    -> (a, Rectangle)
    -> Maybe Rectangle
  pureDecoration :: SideBorderDecoration a
-> Dimension
-> Dimension
-> Rectangle
-> Stack a
-> [(a, Rectangle)]
-> (a, Rectangle)
-> Maybe Rectangle
pureDecoration SideBorderDecoration a
dec Dimension
dw Dimension
dh Rectangle
_ Stack a
st [(a, Rectangle)]
_ (a
win, Rectangle Position
x Position
y Dimension
w Dimension
h)
    | a
win a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Stack a -> [a]
forall a. Stack a -> [a]
W.integrate Stack a
st Bool -> Bool -> Bool
&& Dimension
dw Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
w Bool -> Bool -> Bool
&& Dimension
dh Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
< Dimension
h = Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just (Rectangle -> Maybe Rectangle) -> Rectangle -> Maybe Rectangle
forall a b. (a -> b) -> a -> b
$ case SideBorderDecoration a
dec of
      SideBorderDecoration Direction2D
U -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x                 Position
y                 Dimension
w  Dimension
dh
      SideBorderDecoration Direction2D
R -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dw)) Position
y                 Dimension
dw Dimension
h
      SideBorderDecoration Direction2D
D -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x                 (Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dh)) Dimension
w  Dimension
dh
      SideBorderDecoration Direction2D
L -> Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x                 Position
y                 Dimension
dw Dimension
h
    | Bool
otherwise = Maybe Rectangle
forall a. Maybe a
Nothing

-----------------------------------------------------------------------
-- Shrinker

-- | Kill all text.
data BorderShrinker = BorderShrinker

instance Show BorderShrinker where
  show :: BorderShrinker -> String
  show :: BorderShrinker -> String
show BorderShrinker
_ = String
""

instance Read BorderShrinker where
  readsPrec :: Int -> ReadS BorderShrinker
  readsPrec :: Int -> ReadS BorderShrinker
readsPrec Int
_ String
s = [(BorderShrinker
BorderShrinker, String
s)]

instance Shrinker BorderShrinker where
  shrinkIt :: BorderShrinker -> String -> [String]
  shrinkIt :: BorderShrinker -> String -> [String]
shrinkIt BorderShrinker
_ String
_ = [String
""]