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 -> ColorAndAttrs
foreground :: {-# UNPACK #-} !ColorAndAttrs,
    Style -> ColorAndAttrs
background :: {-# UNPACK #-} !ColorAndAttrs
  }

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

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

-- Render a style as a foreground `Tb_attrs`.
asForeground :: Style -> Tb_attrs
asForeground :: Style -> Tb_attrs
asForeground Style {ColorAndAttrs
$sel:foreground:Style :: Style -> ColorAndAttrs
foreground :: ColorAndAttrs
foreground} =
  ColorAndAttrs -> Tb_attrs
renderColorAndAttr ColorAndAttrs
foreground

-- Render a style as a background `Tb_attrs`.
asBackground :: Style -> Tb_attrs
asBackground :: Style -> Tb_attrs
asBackground Style {ColorAndAttrs
$sel:background:Style :: Style -> ColorAndAttrs
background :: ColorAndAttrs
background} =
  ColorAndAttrs -> Tb_attrs
renderColorAndAttr ColorAndAttrs
background

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

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

maybeFill :: MaybeColor -> Style
maybeFill :: MaybeColor -> Style
maybeFill MaybeColor
color =
  ColorAndAttrs -> Style
onlyBackground ColorAndAttrs {MaybeColor
color :: MaybeColor
$sel:color:ColorAndAttrs :: MaybeColor
color, $sel:attrs:ColorAndAttrs :: Tb_attrs
attrs = Tb_attrs
forall a. Monoid a => a
mempty}

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

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

bold :: Style
bold :: Style
bold =
  ColorAndAttrs -> Style
onlyForeground (Tb_attrs -> ColorAndAttrs
onlyAttr Tb_attrs
_TB_BOLD)

underline :: Style
underline :: Style
underline =
  ColorAndAttrs -> Style
onlyForeground (Tb_attrs -> ColorAndAttrs
onlyAttr Tb_attrs
_TB_UNDERLINE)

blink :: Style
blink :: Style
blink =
  ColorAndAttrs -> Style
onlyBackground (Tb_attrs -> ColorAndAttrs
onlyAttr Tb_attrs
_TB_BOLD)

data ColorAndAttrs = ColorAndAttrs
  { ColorAndAttrs -> MaybeColor
color :: {-# UNPACK #-} !MaybeColor,
    ColorAndAttrs -> Tb_attrs
attrs :: {-# UNPACK #-} !Tb_attrs
  }

instance Monoid ColorAndAttrs where
  mempty :: ColorAndAttrs
mempty =
    MaybeColor -> Tb_attrs -> ColorAndAttrs
ColorAndAttrs MaybeColor
nothingColor Tb_attrs
forall a. Monoid a => a
mempty

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

renderColorAndAttr :: ColorAndAttrs -> Tb_attrs
renderColorAndAttr :: ColorAndAttrs -> Tb_attrs
renderColorAndAttr ColorAndAttrs {MaybeColor
$sel:color:ColorAndAttrs :: ColorAndAttrs -> MaybeColor
color :: MaybeColor
color, Tb_attrs
$sel:attrs:ColorAndAttrs :: ColorAndAttrs -> Tb_attrs
attrs :: Tb_attrs
attrs} =
  Tb_attrs
attrs Tb_attrs -> Tb_attrs -> Tb_attrs
forall a. Semigroup a => a -> a -> a
<> MaybeColor -> Tb_attrs
unMaybeColor MaybeColor
color

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

onlyAttr :: Tb_attrs -> ColorAndAttrs
onlyAttr :: Tb_attrs -> ColorAndAttrs
onlyAttr Tb_attrs
attrs =
  ColorAndAttrs
forall a. Monoid a => a
mempty {attrs}