restman-0.7.3.0: test/Spec.hs

{-# language OverloadedStrings #-}
module Main (main) where

import Data.Bits ((.|.))
import qualified Data.Map.Strict as Map
import Data.Word (Word8)

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Runners.AntXML (antXMLRunner)

import qualified Graphics.Vty.Attributes as VA
import qualified Graphics.Vty.Image as VI

import Skylighting.Types
  ( ANSIColorLevel(..)
  , Color(..)
  , FormatOptions(..)
  , Style(..)
  , TokenType(..)
  , defaultFormatOpts
  )

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

import qualified HTTP.ClientSpec
import qualified LibSpec
import qualified Props.HTTPClientProps
import qualified Props.LibProps
import qualified Props.SkylightingProps
import qualified Props.TypesProps
import qualified TypesSpec
import qualified UISpec

main :: IO ()
main = defaultMainWithIngredients [antXMLRunner] tests

-- | A minimal Style with no token styles and no colors.
emptyStyle :: Style
emptyStyle = Style
  { tokenStyles              = Map.empty
  , defaultColor             = Nothing
  , backgroundColor          = Nothing
  , lineNumberColor          = Nothing
  , lineNumberBackgroundColor = Nothing
  }

tests :: TestTree
tests = testGroup "restman"
  [ HTTP.ClientSpec.tests
  , LibSpec.tests
  , TypesSpec.tests
  , UISpec.tests
  , testGroup "Skylighting.Format.Vty"
      [ attrStyleTests
      , attrColorTests
      , colorDistanceTests
      , formatVtyTests
      , vtyStyleAttrTests
      ]
  , testGroup "property tests"
      [ Props.HTTPClientProps.tests
      , Props.LibProps.tests
      , Props.SkylightingProps.tests
      , Props.TypesProps.tests
      ]
  ]

attrStyleTests :: TestTree
attrStyleTests = testGroup "attrStyle"
  [ testCase "no attributes gives defaultStyleMask" $
      attrStyle False False False @?= VA.defaultStyleMask
  , testCase "bold only" $
      attrStyle True False False @?= VA.bold
  , testCase "italic only" $
      attrStyle False True False @?= VA.italic
  , testCase "underline only" $
      attrStyle False False True @?= VA.underline
  , testCase "bold and underline" $
      attrStyle True False True @?= (VA.bold .|. VA.underline)
  , testCase "all three styles" $
      attrStyle True True True @?= (VA.bold .|. VA.underline .|. VA.italic)
  ]

attrColorTests :: TestTree
attrColorTests = testGroup "attrColor"
  [ testCase "Nothing gives Nothing (TrueColor)" $
      attrColor ANSITrueColor Nothing @?= Nothing
  , testCase "Nothing gives Nothing (16-color)" $
      attrColor ANSI16Color Nothing @?= Nothing
  , testCase "TrueColor red maps to rgbColor" $
      attrColor ANSITrueColor (Just (RGB 255 0 0))
        @?= Just (VA.rgbColor (255 :: Word8) 0 0)
  , testCase "256-color green maps to rgbColor" $
      attrColor ANSI256Color (Just (RGB 0 255 0))
        @?= Just (VA.rgbColor (0 :: Word8) 255 0)
  ]

colorDistanceTests :: TestTree
colorDistanceTests = testGroup "colorDistance"
  [ testCase "identical colors have distance 0" $
      colorDistance (RGB 0 0 0) (RGB 0 0 0) @?= 0
  , testCase "pure red channel contributes 255" $
      colorDistance (RGB 255 0 0) (RGB 0 0 0) @?= 255
  , testCase "multi-channel distance is sum of absolute differences" $
      colorDistance (RGB 3 5 7) (RGB 0 0 0) @?= 15
  , testCase "colorDistance is symmetric" $
      colorDistance (RGB 100 50 25) (RGB 0 0 0)
        @?= colorDistance (RGB 0 0 0) (RGB 100 50 25)
  ]

formatVtyTests :: TestTree
formatVtyTests = testGroup "formatVty"
  [ testCase "empty source list produces empty image" $ do
      let img = formatVty defaultFormatOpts emptyStyle []
      VI.imageWidth  img @?= 0
      VI.imageHeight img @?= 0
  , testCase "single empty source line produces empty image" $ do
      let opts = defaultFormatOpts { numberLines = False }
          img = formatVty opts emptyStyle [[]]
      VI.imageWidth  img @?= 0
      VI.imageHeight img @?= 0
  , testCase "single ASCII token has correct display width" $ do
      let opts = defaultFormatOpts
                   { numberLines    = False
                   , ansiColorLevel = ANSITrueColor
                   }
          img = formatVty opts emptyStyle [[(NormalTok, "hello")]]
      VI.imageWidth img @?= 5
  , testCase "three source lines has height 3" $ do
      let opts = defaultFormatOpts { numberLines = False }
          img = formatVty opts emptyStyle
                  [ [(NormalTok, "a")]
                  , [(NormalTok, "b")]
                  , [(NormalTok, "c")]
                  ]
      VI.imageHeight img @?= 3
  , testCase "number lines enabled produces wider image than without" $ do
      let optsNums = defaultFormatOpts { numberLines = True,  ansiColorLevel = ANSITrueColor }
          optsNoNums = defaultFormatOpts { numberLines = False, ansiColorLevel = ANSITrueColor }
          src = [[(NormalTok, "hello")]]
          imgNums = formatVty optsNums   emptyStyle src
          imgNoNums = formatVty optsNoNums emptyStyle src
      assertBool "image with line numbers should be wider" (VI.imageWidth imgNums > VI.imageWidth imgNoNums)
  ]

vtyStyleAttrTests :: TestTree
vtyStyleAttrTests = testGroup "vtyStyleAttr"
  [ testCase "no color, no style -> all Default except style SetTo defaultStyleMask" $ do
      let a = vtyStyleAttr ANSITrueColor Nothing Nothing False False False
      VA.attrStyle a @?= VA.SetTo VA.defaultStyleMask
      VA.attrForeColor a @?= VA.Default
      VA.attrBackColor a @?= VA.Default
  , testCase "fg Just red -> attrForeColor is SetTo" $ do
      let a = vtyStyleAttr ANSITrueColor (Just (RGB 255 0 0)) Nothing False False False
      case VA.attrForeColor a of
        VA.SetTo _ -> pure ()
        _ -> assertFailure "expected SetTo for fg color"
  , testCase "bg Just green -> attrBackColor is SetTo" $ do
      let a = vtyStyleAttr ANSITrueColor Nothing (Just (RGB 0 255 0)) False False False
      case VA.attrBackColor a of
        VA.SetTo _ -> pure ()
        _ -> assertFailure "expected SetTo for bg color"
  , testCase "bold=True -> bold bit set in style" $ do
      let a = vtyStyleAttr ANSITrueColor Nothing Nothing True False False
      VA.attrStyle a @?= VA.SetTo VA.bold
  , testCase "italic=True -> italic bit set in style" $ do
      let a = vtyStyleAttr ANSITrueColor Nothing Nothing False True False
      VA.attrStyle a @?= VA.SetTo VA.italic
  , testCase "underline=True -> underline bit set in style" $ do
      let a = vtyStyleAttr ANSITrueColor Nothing Nothing False False True
      VA.attrStyle a @?= VA.SetTo VA.underline
  , testCase "attrURL is always Default" $ do
      let a = vtyStyleAttr ANSITrueColor (Just (RGB 1 2 3)) (Just (RGB 4 5 6)) True True True
      VA.attrURL a @?= VA.Default
  ]