module Termbox.Internal.Style
  ( Style,
    asForeground,
    asBackground,
    maybeFill,
    fg,
    bg,
    bold,
    underline,
    blink,
  )
where

import Termbox.Bindings.Hs hiding (bg, fg)
import Termbox.Internal.Color (Color, MaybeColor, justColor, nothingColor, unMaybeColor)

data Style = Style
  { Style -> ColorAndAttr
foreground :: {-# UNPACK #-} !ColorAndAttr,
    Style -> ColorAndAttr
background :: {-# UNPACK #-} !ColorAndAttr
  }

instance Monoid Style where
  mempty :: Style
mempty =
    ColorAndAttr -> ColorAndAttr -> Style
Style ColorAndAttr
forall a. Monoid a => a
mempty ColorAndAttr
forall a. Monoid a => a
mempty

-- right-biased
instance Semigroup Style where
  Style ColorAndAttr
a1 ColorAndAttr
b1 <> :: Style -> Style -> Style
<> Style ColorAndAttr
a2 ColorAndAttr
b2 =
    ColorAndAttr -> ColorAndAttr -> Style
Style (ColorAndAttr
a2 ColorAndAttr -> ColorAndAttr -> ColorAndAttr
forall a. Semigroup a => a -> a -> a
<> ColorAndAttr
a1) (ColorAndAttr
b2 ColorAndAttr -> ColorAndAttr -> ColorAndAttr
forall a. Semigroup a => a -> a -> a
<> ColorAndAttr
b1)

-- Render a style as a foreground `tb_color`.
asForeground :: Style -> Tb_color
asForeground :: Style -> Tb_color
asForeground Style {ColorAndAttr
$sel:foreground:Style :: Style -> ColorAndAttr
foreground :: ColorAndAttr
foreground} =
  ColorAndAttr -> Tb_color
renderColorAndAttr ColorAndAttr
foreground

-- Render a style as a background `tb_color`.
asBackground :: Style -> Tb_color
asBackground :: Style -> Tb_color
asBackground Style {ColorAndAttr
$sel:background:Style :: Style -> ColorAndAttr
background :: ColorAndAttr
background} =
  ColorAndAttr -> Tb_color
renderColorAndAttr ColorAndAttr
background

onlyForeground :: ColorAndAttr -> Style
onlyForeground :: ColorAndAttr -> Style
onlyForeground ColorAndAttr
style =
  Style
forall a. Monoid a => a
mempty {foreground = style}

onlyBackground :: ColorAndAttr -> Style
onlyBackground :: ColorAndAttr -> Style
onlyBackground ColorAndAttr
style =
  Style
forall a. Monoid a => a
mempty {background = style}

maybeFill :: MaybeColor -> Style
maybeFill :: MaybeColor -> Style
maybeFill MaybeColor
color =
  ColorAndAttr -> Style
onlyBackground ColorAndAttr {MaybeColor
color :: MaybeColor
$sel:color:ColorAndAttr :: MaybeColor
color, $sel:attr:ColorAndAttr :: Tb_attr
attr = Tb_attr
forall a. Monoid a => a
mempty}

fg :: Color -> Style
fg :: Color -> Style
fg =
  ColorAndAttr -> Style
onlyForeground (ColorAndAttr -> Style)
-> (Color -> ColorAndAttr) -> Color -> Style
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ColorAndAttr
onlyColor

bg :: Color -> Style
bg :: Color -> Style
bg =
  ColorAndAttr -> Style
onlyBackground (ColorAndAttr -> Style)
-> (Color -> ColorAndAttr) -> Color -> Style
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> ColorAndAttr
onlyColor

bold :: Style
bold :: Style
bold =
  ColorAndAttr -> Style
onlyForeground (Tb_attr -> ColorAndAttr
onlyAttr Tb_attr
TB_BOLD)

underline :: Style
underline :: Style
underline =
  ColorAndAttr -> Style
onlyForeground (Tb_attr -> ColorAndAttr
onlyAttr Tb_attr
TB_UNDERLINE)

blink :: Style
blink :: Style
blink =
  ColorAndAttr -> Style
onlyBackground (Tb_attr -> ColorAndAttr
onlyAttr Tb_attr
TB_BOLD)

data ColorAndAttr = ColorAndAttr
  { ColorAndAttr -> MaybeColor
color :: {-# UNPACK #-} !MaybeColor,
    ColorAndAttr -> Tb_attr
attr :: {-# UNPACK #-} !Tb_attr
  }

instance Monoid ColorAndAttr where
  mempty :: ColorAndAttr
mempty =
    MaybeColor -> Tb_attr -> ColorAndAttr
ColorAndAttr MaybeColor
nothingColor Tb_attr
forall a. Monoid a => a
mempty

-- right-biased
instance Semigroup ColorAndAttr where
  ColorAndAttr MaybeColor
color1 Tb_attr
attr1 <> :: ColorAndAttr -> ColorAndAttr -> ColorAndAttr
<> ColorAndAttr MaybeColor
color2 Tb_attr
attr2 =
    MaybeColor -> Tb_attr -> ColorAndAttr
ColorAndAttr
      (if MaybeColor
color2 MaybeColor -> MaybeColor -> Bool
forall a. Eq a => a -> a -> Bool
== MaybeColor
nothingColor then MaybeColor
color1 else MaybeColor
color2)
      (Tb_attr
attr1 Tb_attr -> Tb_attr -> Tb_attr
forall a. Semigroup a => a -> a -> a
<> Tb_attr
attr2)

renderColorAndAttr :: ColorAndAttr -> Tb_color
renderColorAndAttr :: ColorAndAttr -> Tb_color
renderColorAndAttr ColorAndAttr {MaybeColor
$sel:color:ColorAndAttr :: ColorAndAttr -> MaybeColor
color :: MaybeColor
color, Tb_attr
$sel:attr:ColorAndAttr :: ColorAndAttr -> Tb_attr
attr :: Tb_attr
attr} =
  Tb_attr -> Tb_color -> Tb_color
tb_attr Tb_attr
attr (MaybeColor -> Tb_color
unMaybeColor MaybeColor
color)

onlyColor :: Color -> ColorAndAttr
onlyColor :: Color -> ColorAndAttr
onlyColor Color
color =
  ColorAndAttr
forall a. Monoid a => a
mempty {color = justColor color}

onlyAttr :: Tb_attr -> ColorAndAttr
onlyAttr :: Tb_attr -> ColorAndAttr
onlyAttr Tb_attr
attr =
  ColorAndAttr
forall a. Monoid a => a
mempty {attr}