StyleSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Reflex.Vty.StyleSpec (spec) where

import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Graphics.Vty as V
import qualified Graphics.Vty.Attributes.Color as V.Color
import qualified Graphics.Vty.Image as V.Image
import Test.Hspec

import Reflex.Vty.Style
import Reflex.Vty.Test.Snapshot (Grid (..), RenderSpan (..), imageText, imageToGrid)

spec :: Spec
spec = describe "Reflex.Vty.Style" $ do
  describe "inherit" $ do
    let parent = withForeground red . withBold . withWidth 10 $ def
    it "keeps the child's foreground when set" $ do
      let child = withForeground blue def
      _style_foreground (inherit parent child) `shouldBe` Just blue
    it "inherits the parent's foreground when the child's is Nothing" $ do
      let child = def
      _style_foreground (inherit parent child) `shouldBe` Just red
    it "keeps the child's width when set" $ do
      let child = withWidth 5 def
      _style_width (inherit parent child) `shouldBe` Just 5
    it "inherits the parent's width when the child's is Nothing" $ do
      let child = def
      _style_width (inherit parent child) `shouldBe` Just 10
    it "inherits the parent's bold flag when the child's is Nothing" $ do
      let child = def
      _style_bold (inherit parent child) `shouldBe` Just True

  describe "applyAttr" $ do
    it "applies the foreground color" $ do
      let s = withForeground red def
      V.attrForeColor (applyAttr s V.defAttr) `shouldBe` V.SetTo red
    it "applies the background color" $ do
      let s = withBackground blue def
      V.attrBackColor (applyAttr s V.defAttr) `shouldBe` V.SetTo blue
    it "applies bold when Just True" $ do
      let s = withBold def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.bold `shouldBe` True
    it "does not apply bold when Nothing" $ do
      V.hasStyle (V.styleMask (applyAttr def V.defAttr)) V.bold `shouldBe` False
    it "applies underline for UnderlineSingle" $ do
      let s = withUnderline UnderlineSingle def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` True
    it "does not apply underline for UnderlineNone" $ do
      let s = withUnderline UnderlineNone def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.underline `shouldBe` False
    it "applies italic" $ do
      let s = withItalic def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.italic `shouldBe` True
    it "applies faint (dim)" $ do
      let s = withFaint def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.dim `shouldBe` True
    it "applies blink" $ do
      let s = withBlink def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.blink `shouldBe` True
    it "applies strikethrough" $ do
      let s = withStrikethrough def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.strikethrough `shouldBe` True
    it "applies reverse video" $ do
      let s = withReverse def
      V.hasStyle (V.styleMask (applyAttr s V.defAttr)) V.reverseVideo `shouldBe` True
    it "applies the hyperlink URL" $ do
      let s = withHyperlink "https://example.com" def
      V.attrURL (applyAttr s V.defAttr) `shouldBe` V.SetTo "https://example.com"
    it "leaves the base attr unchanged for def" $ do
      applyAttr def V.defAttr `shouldBe` V.defAttr

  describe "mergeAttr" $ do
    let base = V.defAttr `V.withForeColor` red `V.withBackColor` blue
    it "uses overlay's SetTo fields over the base" $ do
      let overlay = V.defAttr `V.withForeColor` green
          result = mergeAttr base overlay
      V.attrForeColor result `shouldBe` V.SetTo green
      V.attrBackColor result `shouldBe` V.SetTo blue
    it "falls through to base when overlay is Default" $ do
      let overlay = V.defAttr
          result = mergeAttr base overlay
      V.attrForeColor result `shouldBe` V.SetTo red
      V.attrBackColor result `shouldBe` V.SetTo blue
    it "falls through to base when overlay is KeepCurrent" $ do
      let overlay = V.Attr {V.attrStyle = V.KeepCurrent, V.attrForeColor = V.KeepCurrent, V.attrBackColor = V.KeepCurrent, V.attrURL = V.KeepCurrent}
          result = mergeAttr base overlay
      V.attrForeColor result `shouldBe` V.SetTo red

  describe "render" $ do
    it "produces a non-empty image for plain text" $ do
      let img = render def "hello"
      V.Image.imageWidth img `shouldSatisfy` (> 0)
      V.Image.imageHeight img `shouldBe` 1
    it "respects withWidth by padding" $ do
      let img = render (withWidth 10 def) "hi"
      V.Image.imageWidth img `shouldBe` 10
    it "respects withHeight by padding" $ do
      let img = render (withHeight 3 def) "hi"
      V.Image.imageHeight img `shouldBe` 3
    it "respects withMaxWidth by clipping" $ do
      let img = render (withMaxWidth 3 def) "hello"
      V.Image.imageWidth img `shouldBe` 3
    it "respects withMaxHeight by clipping" $ do
      let img = render (withMaxHeight 1 def) "hello"
      V.Image.imageHeight img `shouldBe` 1
    it "adds padding around content" $ do
      let s = withPadding 1 1 1 1 def
          img = render s "hi"
      V.Image.imageWidth img `shouldBe` 4
      V.Image.imageHeight img `shouldBe` 3
    it "adds a border around content" $ do
      let s = withBorder singleBorder def
          img = render s "hi"
      V.Image.imageWidth img `shouldBe` 4
      V.Image.imageHeight img `shouldBe` 3
    it "adds margin outside content" $ do
      let s = withMargin 1 1 1 1 def
          img = render s "hi"
      V.Image.imageWidth img `shouldBe` 4
      V.Image.imageHeight img `shouldBe` 3
    it "renders multi-line text with correct height" $ do
      let img = render def "hello\nworld"
      V.Image.imageHeight img `shouldBe` 2
    it "renders multi-line text width as longest line" $ do
      let img = render def "hello\nhi"
      V.Image.imageWidth img `shouldBe` 5
    it "renders wide characters at correct width" $ do
      let img = render def "文"
      V.Image.imageWidth img `shouldBe` 2

  describe "measure" $ do
    it "matches render's width for plain text" $ do
      let s = def
      fst (measure s "hello") `shouldBe` V.Image.imageWidth (render s "hello")
    it "accounts for padding" $ do
      let s = withPadding 2 3 2 3 def
      fst (measure s "hi") `shouldBe` 2 + 3 + 3
    it "accounts for border" $ do
      let s = withBorder singleBorder def
      fst (measure s "hi") `shouldBe` 2 + 2
    it "accounts for margin" $ do
      let s = withMargin 1 1 1 1 def
      fst (measure s "hi") `shouldBe` 2 + 2
    it "measures multi-line text with correct height" $ do
      snd (measure def "hello\nworld") `shouldBe` 2
    it "measures multi-line text with correct width" $ do
      fst (measure def "hello\nhi") `shouldBe` 5
    it "measures multi-line text with matching render dimensions" $ do
      let s = withBorder singleBorder def
          (w, h) = measure s "hello\nworld"
          img = render s "hello\nworld"
      w `shouldBe` V.Image.imageWidth img
      h `shouldBe` V.Image.imageHeight img
    it "measures wide characters at display width" $ do
      fst (measure def "文") `shouldBe` 2
    it "measures mixed wide and narrow characters" $ do
      fst (measure def "a文b") `shouldBe` 4
    it "measures empty content as zero width, one line" $ do
      measure def "" `shouldBe` (0, 1)

  describe "withTransform" $ do
    it "applies transform before rendering" $ do
      let img = render (withTransform T.toUpper def) "hello"
      V.Image.imageWidth img `shouldBe` 5

    it "renders transformed text" $ do
      let img = render (withTransform (T.replace "a" "AA") def) "cat"
      V.Image.imageWidth img `shouldBe` 4

  describe "withTabWidth" $ do
    it "expands tabs to spaces" $ do
      let img = render (withTabWidth 4 def) "a\tb"
      V.Image.imageWidth img `shouldBe` 6

    it "does not expand tabs when not set" $ do
      let img = render def "a\tb"
      V.Image.imageWidth img `shouldSatisfy` (< 6)

  describe "withMarginBackground" $ do
    it "produces correct dimensions with margin background" $ do
      let s = withMarginBackground red . withMargin 1 1 1 1 $ def
          (w, h) = measure s "hi"
      w `shouldBe` 4
      h `shouldBe` 3

  describe "new border presets" $ do
    it "innerHalfBorder has all sides" $ do
      _border_top innerHalfBorder `shouldBe` Just '▀'
      _border_left innerHalfBorder `shouldBe` Just '▌'
    it "outerHalfBlockBorder has all sides" $ do
      _border_top outerHalfBlockBorder `shouldBe` Just '▔'
      _border_left outerHalfBlockBorder `shouldBe` Just '▏'
    it "renders innerHalfBorder" $ do
      let img = render (withBorder innerHalfBorder def) "X"
      V.Image.imageWidth img `shouldBe` 3
      V.Image.imageHeight img `shouldBe` 3

  describe "image composition coordinates" $ do
    let imgA = render def "ab"
        imgTall = render def "x\ny"
    it "placeHorizontal aligns content within the padded width" $ do
      imageText (placeHorizontal HAlignLeft 5 imgA) `shouldBe` ["ab   "]
      imageText (placeHorizontal HAlignCenter 5 imgA) `shouldBe` [" ab  "]
      imageText (placeHorizontal HAlignRight 5 imgA) `shouldBe` ["   ab"]
    it "placeVertical aligns content within the padded height" $ do
      imageText (placeVertical VAlignTop 3 imgA) `shouldBe` ["ab", "  ", "  "]
      imageText (placeVertical VAlignBottom 3 imgA) `shouldBe` ["  ", "  ", "ab"]
    it "place combines both axes" $ do
      imageText (place HAlignRight VAlignBottom 4 2 imgA) `shouldBe` ["    ", "  ab"]
    it "joinHorizontal pads to the tallest and concatenates widths" $ do
      let joined = joinHorizontal VAlignTop [imgA, imgTall]
      V.imageWidth joined `shouldBe` 3
      V.imageHeight joined `shouldBe` 2
      imageText joined `shouldBe` ["abx", "  y"]
    it "joinVertical pads to the widest and stacks heights" $ do
      let joined = joinVertical HAlignRight [imgA, imgTall]
      V.imageWidth joined `shouldBe` 2
      V.imageHeight joined `shouldBe` 3
      imageText joined `shouldBe` ["ab", " x", " y"]
    it "placeHorizontal leaves oversized images untouched" $ do
      imageText (placeHorizontal HAlignCenter 1 imgA) `shouldBe` ["ab"]

  describe "hyperlinks" $ do
    it "renders the URL attribute onto the text" $ do
      let img = render (withHyperlink "https://example.com" def) "link"
          grid = imageToGrid img
      case gridRows grid of
        [[s]] -> do
          V.fixedURL (renderSpanAttr s) `shouldBe` Just "https://example.com"
          T.unpack (renderSpanText s) `shouldBe` "link"
        _ -> expectationFailure "expected one row with one span"