SkylightingProps.hs

module Props.SkylightingProps (tests) where

-- base
import Data.Bits ((.&.))
import Data.Word (Word8)

-- hedgehog
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

-- tasty / tasty-hedgehog
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

-- vty
import qualified Graphics.Vty.Attributes as VA

-- skylighting
import Skylighting.Types (ANSIColorLevel(..), Color(..))

-- restman
import Skylighting.Format.Vty
  (attrColor, attrStyle, colorDistance, vtyStyleAttr)

tests :: TestTree
tests = testGroup "Props.Skylighting.Format.Vty"
  [ colorDistanceProps
  , attrStyleProps
  , attrColorProps
  , vtyStyleAttrProps
  ]

-- ---------------------------------------------------------------------------
-- Generators
-- ---------------------------------------------------------------------------

genWord8 :: Gen Word8
genWord8 = Gen.word8 Range.linearBounded

genColor :: Gen Color
genColor = RGB
  <$> genWord8
  <*> genWord8
  <*> genWord8

genColorLevel :: Gen ANSIColorLevel
genColorLevel = Gen.element [ANSITrueColor, ANSI256Color, ANSI16Color]

-- ---------------------------------------------------------------------------
-- colorDistance properties
--
-- colorDistance :: Color -> Color -> Int16
-- Defined as the L1 (Manhattan) distance over RGB channels.
-- ---------------------------------------------------------------------------

-- Distance from a color to itself is zero.
prop_colorDistance_self_zero :: Property
prop_colorDistance_self_zero = property $ do
  c <- forAll genColor
  colorDistance c c === 0

-- Distance is symmetric: d(a,b) == d(b,a).
prop_colorDistance_symmetric :: Property
prop_colorDistance_symmetric = property $ do
  a <- forAll genColor
  b <- forAll genColor
  colorDistance a b === colorDistance b a

-- Distance is always non-negative.
prop_colorDistance_nonneg :: Property
prop_colorDistance_nonneg = property $ do
  a <- forAll genColor
  b <- forAll genColor
  assert (colorDistance a b >= 0)

-- Triangle inequality: d(a,c) <= d(a,b) + d(b,c).
prop_colorDistance_triangle :: Property
prop_colorDistance_triangle = property $ do
  a <- forAll genColor
  b <- forAll genColor
  c <- forAll genColor
  assert (colorDistance a c <= colorDistance a b + colorDistance b c)

colorDistanceProps :: TestTree
colorDistanceProps = testGroup "colorDistance"
  [ testProperty "self distance is zero"   prop_colorDistance_self_zero
  , testProperty "symmetric"               prop_colorDistance_symmetric
  , testProperty "non-negative"            prop_colorDistance_nonneg
  , testProperty "triangle inequality"     prop_colorDistance_triangle
  ]

-- ---------------------------------------------------------------------------
-- attrStyle properties
--
-- attrStyle :: Bool -> Bool -> Bool -> VA.Style
-- Each Bool selects whether bold, italic, or underline bits are set.
-- ---------------------------------------------------------------------------

-- When bold=True the bold bit is set; when False it is clear.
prop_attrStyle_bold_bit :: Property
prop_attrStyle_bold_bit = property $ do
  b <- forAll Gen.bool
  i <- forAll Gen.bool
  u <- forAll Gen.bool
  let s = attrStyle b i u
  (s .&. VA.bold /= 0) === b

-- When italic=True the italic bit is set; when False it is clear.
prop_attrStyle_italic_bit :: Property
prop_attrStyle_italic_bit = property $ do
  b <- forAll Gen.bool
  i <- forAll Gen.bool
  u <- forAll Gen.bool
  let s = attrStyle b i u
  (s .&. VA.italic /= 0) === i

-- When underline=True the underline bit is set; when False it is clear.
prop_attrStyle_underline_bit :: Property
prop_attrStyle_underline_bit = property $ do
  b <- forAll Gen.bool
  i <- forAll Gen.bool
  u <- forAll Gen.bool
  let s = attrStyle b i u
  (s .&. VA.underline /= 0) === u

-- All flags False gives the defaultStyleMask (no bits set by us).
prop_attrStyle_all_false_is_default :: Property
prop_attrStyle_all_false_is_default = property $
  attrStyle False False False === VA.defaultStyleMask

-- Flags are independent: toggling one Bool does not affect the other bits.
prop_attrStyle_flags_independent :: Property
prop_attrStyle_flags_independent = property $ do
  i <- forAll Gen.bool
  u <- forAll Gen.bool
  -- flip bold only
  let withBold = attrStyle True  i u
      withoutBold = attrStyle False i u
  -- italic and underline bits should be the same in both
  (withBold    .&. VA.italic)     === (withoutBold .&. VA.italic)
  (withBold    .&. VA.underline)  === (withoutBold .&. VA.underline)

attrStyleProps :: TestTree
attrStyleProps = testGroup "attrStyle"
  [ testProperty "bold flag controls bold bit"        prop_attrStyle_bold_bit
  , testProperty "italic flag controls italic bit"    prop_attrStyle_italic_bit
  , testProperty "underline flag controls underline"  prop_attrStyle_underline_bit
  , testProperty "all False gives defaultStyleMask"   prop_attrStyle_all_false_is_default
  , testProperty "flags are independent"              prop_attrStyle_flags_independent
  ]

-- ---------------------------------------------------------------------------
-- attrColor properties
--
-- attrColor :: ANSIColorLevel -> Maybe Color -> Maybe VA.Color
-- Nothing input always gives Nothing output (color level irrelevant).
-- Just input always gives Just output.
-- ---------------------------------------------------------------------------

-- Nothing maps to Nothing for all color levels.
prop_attrColor_nothing_to_nothing :: Property
prop_attrColor_nothing_to_nothing = property $ do
  clv <- forAll genColorLevel
  attrColor clv Nothing === Nothing

-- Just a color always produces Just a vty color (never Nothing).
prop_attrColor_just_to_just :: Property
prop_attrColor_just_to_just = property $ do
  clv <- forAll genColorLevel
  col <- forAll genColor
  case attrColor clv (Just col) of
    Nothing -> failure
    Just _ -> success

-- For TrueColor and 256-color, identical RGB inputs yield identical outputs.
prop_attrColor_same_rgb_same_result :: Property
prop_attrColor_same_rgb_same_result = property $ do
  clv <- forAll genColorLevel
  col <- forAll genColor
  attrColor clv (Just col) === attrColor clv (Just col)

attrColorProps :: TestTree
attrColorProps = testGroup "attrColor"
  [ testProperty "Nothing -> Nothing for all levels"  prop_attrColor_nothing_to_nothing
  , testProperty "Just -> Just for all levels"        prop_attrColor_just_to_just
  , testProperty "same input gives same output"       prop_attrColor_same_rgb_same_result
  ]

-- ---------------------------------------------------------------------------
-- vtyStyleAttr properties
--
-- vtyStyleAttr :: ANSIColorLevel -> Maybe Color -> Maybe Color
--              -> Bool -> Bool -> Bool -> VA.Attr
-- ---------------------------------------------------------------------------

-- fg Nothing -> attrForeColor is Default.
prop_vtyStyleAttr_fg_nothing_default :: Property
prop_vtyStyleAttr_fg_nothing_default = property $ do
  clv <- forAll genColorLevel
  bgc <- forAll (Gen.maybe genColor)
  b   <- forAll Gen.bool
  i   <- forAll Gen.bool
  u   <- forAll Gen.bool
  VA.attrForeColor (vtyStyleAttr clv Nothing bgc b i u) === VA.Default

-- fg Just -> attrForeColor is SetTo.
prop_vtyStyleAttr_fg_just_set :: Property
prop_vtyStyleAttr_fg_just_set = property $ do
  clv <- forAll genColorLevel
  fgc <- forAll genColor
  bgc <- forAll (Gen.maybe genColor)
  b   <- forAll Gen.bool
  i   <- forAll Gen.bool
  u   <- forAll Gen.bool
  case VA.attrForeColor (vtyStyleAttr clv (Just fgc) bgc b i u) of
    VA.SetTo _ -> success
    _ -> failure

-- bg Nothing -> attrBackColor is Default.
prop_vtyStyleAttr_bg_nothing_default :: Property
prop_vtyStyleAttr_bg_nothing_default = property $ do
  clv <- forAll genColorLevel
  fgc <- forAll (Gen.maybe genColor)
  b   <- forAll Gen.bool
  i   <- forAll Gen.bool
  u   <- forAll Gen.bool
  VA.attrBackColor (vtyStyleAttr clv fgc Nothing b i u) === VA.Default

-- bg Just -> attrBackColor is SetTo.
prop_vtyStyleAttr_bg_just_set :: Property
prop_vtyStyleAttr_bg_just_set = property $ do
  clv <- forAll genColorLevel
  fgc <- forAll (Gen.maybe genColor)
  bgc <- forAll genColor
  b   <- forAll Gen.bool
  i   <- forAll Gen.bool
  u   <- forAll Gen.bool
  case VA.attrBackColor (vtyStyleAttr clv fgc (Just bgc) b i u) of
    VA.SetTo _ -> success
    _ -> failure

-- attrURL is always Default.
prop_vtyStyleAttr_url_always_default :: Property
prop_vtyStyleAttr_url_always_default = property $ do
  clv <- forAll genColorLevel
  fgc <- forAll (Gen.maybe genColor)
  bgc <- forAll (Gen.maybe genColor)
  b   <- forAll Gen.bool
  i   <- forAll Gen.bool
  u   <- forAll Gen.bool
  VA.attrURL (vtyStyleAttr clv fgc bgc b i u) === VA.Default

vtyStyleAttrProps :: TestTree
vtyStyleAttrProps = testGroup "vtyStyleAttr"
  [ testProperty "fg Nothing -> Default foreground"    prop_vtyStyleAttr_fg_nothing_default
  , testProperty "fg Just -> SetTo foreground"         prop_vtyStyleAttr_fg_just_set
  , testProperty "bg Nothing -> Default background"    prop_vtyStyleAttr_bg_nothing_default
  , testProperty "bg Just -> SetTo background"         prop_vtyStyleAttr_bg_just_set
  , testProperty "attrURL is always Default"           prop_vtyStyleAttr_url_always_default
  ]