{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Special border drawing functions that can include labels in more
-- places than just the top center.
module Swarm.TUI.Border (
  -- * Horizontal border labels
  HBorderLabels,
  plainHBorder,
  leftLabel,
  centerLabel,
  rightLabel,

  -- * Rectangular border labels
  BorderLabels,
  plainBorder,
  topLabels,
  bottomLabels,

  -- * Border-drawing functions
  hBorderWithLabels,
  borderWithLabels,
) where

import Brick
import Brick.Widgets.Border
import Control.Lens (makeLenses, to, (^.))
import Data.Function ((&))
import Graphics.Vty qualified as V

-- | Labels for a horizontal border, with optional left, middle, and
--   right labels.
data HBorderLabels n = HBorderLabels
  { forall n. HBorderLabels n -> Maybe (Widget n)
_leftLabel :: Maybe (Widget n)
  , forall n. HBorderLabels n -> Maybe (Widget n)
_centerLabel :: Maybe (Widget n)
  , forall n. HBorderLabels n -> Maybe (Widget n)
_rightLabel :: Maybe (Widget n)
  }

-- | A plain horizontal border with no labels.
plainHBorder :: HBorderLabels n
plainHBorder :: forall n. HBorderLabels n
plainHBorder = Maybe (Widget n)
-> Maybe (Widget n) -> Maybe (Widget n) -> HBorderLabels n
forall n.
Maybe (Widget n)
-> Maybe (Widget n) -> Maybe (Widget n) -> HBorderLabels n
HBorderLabels Maybe (Widget n)
forall a. Maybe a
Nothing Maybe (Widget n)
forall a. Maybe a
Nothing Maybe (Widget n)
forall a. Maybe a
Nothing

-- | Labels for a rectangular border, with optional left, middle, and
--   right labels on the top and bottom.
data BorderLabels n = BorderLabels
  { forall n. BorderLabels n -> HBorderLabels n
_topLabels :: HBorderLabels n
  , forall n. BorderLabels n -> HBorderLabels n
_bottomLabels :: HBorderLabels n
  }

-- | A plain rectangular border with no labels.
plainBorder :: BorderLabels n
plainBorder :: forall n. BorderLabels n
plainBorder = HBorderLabels n -> HBorderLabels n -> BorderLabels n
forall n. HBorderLabels n -> HBorderLabels n -> BorderLabels n
BorderLabels HBorderLabels n
forall n. HBorderLabels n
plainHBorder HBorderLabels n
forall n. HBorderLabels n
plainHBorder

makeLenses ''HBorderLabels
makeLenses ''BorderLabels

-- | Draw a horizontal border with three optional labels.  The left
--   label (if present) will be placed two units away from the left
--   end of the border, and the right label will be placed two units
--   away from the right end.  The center label, if present, will
--   always be centered in the border overall, regardless of the width
--   of the left and right labels.  This ensures that when the labels
--   change width, they do not cause the other labels to wiggle.
hBorderWithLabels ::
  HBorderLabels n -> Widget n
hBorderWithLabels :: forall n. HBorderLabels n -> Widget n
hBorderWithLabels (HBorderLabels Maybe (Widget n)
l Maybe (Widget n)
c Maybe (Widget n)
r) =
  Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
    let renderLabel :: Maybe (Widget n) -> RenderM n (Result n)
renderLabel = Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> (Maybe (Widget n) -> Widget n)
-> Maybe (Widget n)
-> RenderM n (Result n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget n -> (Widget n -> Widget n) -> Maybe (Widget n) -> Widget n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Widget n
forall n. Widget n
emptyWidget (Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit Int
1)
    Result n
rl <- Maybe (Widget n) -> RenderM n (Result n)
forall {n}. Maybe (Widget n) -> RenderM n (Result n)
renderLabel Maybe (Widget n)
l
    Result n
rc <- Maybe (Widget n) -> RenderM n (Result n)
forall {n}. Maybe (Widget n) -> RenderM n (Result n)
renderLabel Maybe (Widget n)
c
    Result n
rr <- Maybe (Widget n) -> RenderM n (Result n)
forall {n}. Maybe (Widget n) -> RenderM n (Result n)
renderLabel Maybe (Widget n)
r

    -- Figure out how wide the whole border is supposed to be
    Context n
ctx <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext
    let w :: Int
w = Context n
ctx Context n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL

        -- Get the widths of the labels
        lw :: Int
lw = Image -> Int
V.imageWidth (Result n -> Image
forall n. Result n -> Image
image Result n
rl)
        cw :: Int
cw = Image -> Int
V.imageWidth (Result n -> Image
forall n. Result n -> Image
image Result n
rc)

    -- Now render the border with labels.
    Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$
      [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
hBox
        [ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit Int
2 Widget n
forall n. Widget n
hBorder
        , Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
rl)
        , -- We calculate the specific width of border between the left
          -- and center labels needed to ensure that the center label is
          -- in the right place.  Note, using (cw + 1) `div` 2, as
          -- opposed to cw `div` 2, means that the placement of the
          -- center label will be left-biased: if it does not fit
          -- exactly at the center it will be placed just to the left of
          -- center.
          Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit (Int
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lw Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
cw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Widget n
forall n. Widget n
hBorder
        , Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
rc)
        , -- The border between center and right greedily fills up any
          -- remaining width.
          Widget n
forall n. Widget n
hBorder
        , Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
rr)
        , Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit Int
2 Widget n
forall n. Widget n
hBorder
        ]

-- | Put a rectangular border around the specified widget with the
--   specified label widgets placed around the border.
borderWithLabels :: BorderLabels n -> Widget n -> Widget n
borderWithLabels :: forall n. BorderLabels n -> Widget n -> Widget n
borderWithLabels BorderLabels n
labels Widget n
wrapped =
  Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget (Widget n -> Size
forall n. Widget n -> Size
hSize Widget n
wrapped) (Widget n -> Size
forall n. Widget n -> Size
vSize Widget n
wrapped) (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
    Context n
c <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext

    Result n
middleResult <-
      Widget n
wrapped
        Widget n -> (Widget n -> Widget n) -> Widget n
forall a b. a -> (a -> b) -> b
& Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit (Context n
c Context n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availHeightL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
        Widget n -> (Widget n -> Widget n) -> Widget n
forall a b. a -> (a -> b) -> b
& Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit (Context n
c Context n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
        Widget n
-> (Widget n -> RenderM n (Result n)) -> RenderM n (Result n)
forall a b. a -> (a -> b) -> b
& Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render

    let tl :: Widget n
tl = Edges Bool -> Widget n
forall n. Edges Bool -> Widget n
joinableBorder (Bool -> Bool -> Bool -> Bool -> Edges Bool
forall a. a -> a -> a -> a -> Edges a
Edges Bool
False Bool
True Bool
False Bool
True)
        tr :: Widget n
tr = Edges Bool -> Widget n
forall n. Edges Bool -> Widget n
joinableBorder (Bool -> Bool -> Bool -> Bool -> Edges Bool
forall a. a -> a -> a -> a -> Edges a
Edges Bool
False Bool
True Bool
True Bool
False)
        bl :: Widget n
bl = Edges Bool -> Widget n
forall n. Edges Bool -> Widget n
joinableBorder (Bool -> Bool -> Bool -> Bool -> Edges Bool
forall a. a -> a -> a -> a -> Edges a
Edges Bool
True Bool
False Bool
False Bool
True)
        br :: Widget n
br = Edges Bool -> Widget n
forall n. Edges Bool -> Widget n
joinableBorder (Bool -> Bool -> Bool -> Bool -> Edges Bool
forall a. a -> a -> a -> a -> Edges a
Edges Bool
True Bool
False Bool
True Bool
False)
        top :: Widget n
top = Widget n
forall n. Widget n
tl Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> HBorderLabels n -> Widget n
forall n. HBorderLabels n -> Widget n
hBorderWithLabels (BorderLabels n
labels BorderLabels n
-> Getting (HBorderLabels n) (BorderLabels n) (HBorderLabels n)
-> HBorderLabels n
forall s a. s -> Getting a s a -> a
^. Getting (HBorderLabels n) (BorderLabels n) (HBorderLabels n)
forall n (f :: * -> *).
Functor f =>
(HBorderLabels n -> f (HBorderLabels n))
-> BorderLabels n -> f (BorderLabels n)
topLabels) Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Widget n
forall n. Widget n
tr
        bottom :: Widget n
bottom = Widget n
forall n. Widget n
bl Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> HBorderLabels n -> Widget n
forall n. HBorderLabels n -> Widget n
hBorderWithLabels (BorderLabels n
labels BorderLabels n
-> Getting (HBorderLabels n) (BorderLabels n) (HBorderLabels n)
-> HBorderLabels n
forall s a. s -> Getting a s a -> a
^. Getting (HBorderLabels n) (BorderLabels n) (HBorderLabels n)
forall n (f :: * -> *).
Functor f =>
(HBorderLabels n -> f (HBorderLabels n))
-> BorderLabels n -> f (BorderLabels n)
bottomLabels) Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Widget n
forall n. Widget n
br
        middle :: Widget n
middle = Widget n
forall n. Widget n
vBorder Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (Result n -> RenderM n (Result n)
forall a. a -> ReaderT (Context n) (State (RenderState n)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
middleResult) Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Widget n
forall n. Widget n
vBorder
        total :: Widget n
total = Widget n
top Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<=> Widget n
middle Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<=> Widget n
bottom

    Widget n
total
      Widget n -> (Widget n -> Widget n) -> Widget n
forall a b. a -> (a -> b) -> b
& Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit (Result n
middleResult Result n -> Getting Int (Result n) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Image -> Const Int Image) -> Result n -> Const Int (Result n)
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL ((Image -> Const Int Image) -> Result n -> Const Int (Result n))
-> ((Int -> Const Int Int) -> Image -> Const Int Image)
-> Getting Int (Result n) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image -> Int)
-> (Int -> Const Int Int) -> Image -> Const Int Image
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Image -> Int
V.imageHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      Widget n -> (Widget n -> Widget n) -> Widget n
forall a b. a -> (a -> b) -> b
& Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit (Result n
middleResult Result n -> Getting Int (Result n) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Image -> Const Int Image) -> Result n -> Const Int (Result n)
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL ((Image -> Const Int Image) -> Result n -> Const Int (Result n))
-> ((Int -> Const Int Int) -> Image -> Const Int Image)
-> Getting Int (Result n) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image -> Int)
-> (Int -> Const Int Int) -> Image -> Const Int Image
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Image -> Int
V.imageWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      Widget n
-> (Widget n -> RenderM n (Result n)) -> RenderM n (Result n)
forall a b. a -> (a -> b) -> b
& Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render