{-# OPTIONS_GHC -fno-warn-orphans #-}
module NormalizationSpec (spec) where

import Test.Hspec
import Test.QuickCheck
import Data.Word (Word8)

import Blessings

--------------------------------------------------------------------------------
-- Arbitrary instances
--------------------------------------------------------------------------------

instance Arbitrary FColor where
  arbitrary =
    oneof
      [ ECMA48FColor <$> elements ([30..37] <> [90..97] <> [39])
      , Xterm256FColor <$> arbitrary
      , ISO8613_3FColor <$> arbitrary <*> arbitrary <*> arbitrary
      ]

instance Arbitrary BColor where
  arbitrary =
    oneof
      [ ECMA48BColor <$> elements ([40..47] <> [49])
      , Xterm256BColor <$> arbitrary
      , ISO8613_3BColor <$> arbitrary <*> arbitrary <*> arbitrary
      ]

instance Arbitrary Blink where
  arbitrary = elements [Blink, NoBlink]

instance Arbitrary Bold where
  arbitrary = elements [Bold, NoBold]

instance Arbitrary Underline where
  arbitrary = elements [Underline, NoUnderline]

instance Arbitrary Style where
  arbitrary =
    Style <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

instance Arbitrary (Blessings String) where
  arbitrary = sized genBlessings
    where
      genBlessings 0 =
        oneof
          [ pure Empty
          , Plain <$> arbitrary
          ]
      genBlessings n =
        oneof
          [ pure Empty
          , Plain <$> arbitrary
          , SGR <$> arbitraryPm <*> genBlessings (n `div` 2)
          , Append <$> genBlessings (n `div` 2) <*> genBlessings (n `div` 2)
          ]

      arbitraryPm :: Gen [Word8]
      arbitraryPm = listOf arbitrary

  shrink = shrinkBlessings

shrinkBlessings :: Blessings String -> [Blessings String]
shrinkBlessings = \case
  Empty        -> []
  Plain s      -> Empty : [ Plain s' | s' <- shrink s ]
  SGR pm a     ->
    [a] <>
    [ SGR pm' a | pm' <- shrinkList (const []) pm ] <>
    [ SGR pm a' | a' <- shrinkBlessings a ]
  Append a b   ->
    [a, b] <>
    [ Append a' b | a' <- shrinkBlessings a ] <>
    [ Append a b' | b' <- shrinkBlessings b ]

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

allSgrNodes :: Blessings String -> [(Style, [Word8])]
allSgrNodes = go defaultStyle
  where
    go :: Style -> Blessings String -> [(Style, [Word8])]
    go st = \case
      Empty      -> []
      Plain _    -> []
      Append a b -> go st a ++ go st b
      SGR pm a   ->
        let st' = applyPm st pm
        in (st, pm) : go st' a

allPm :: Blessings String -> [[Word8]]
allPm = \case
  Empty      -> []
  Plain _    -> []
  Append a b -> allPm a ++ allPm b
  SGR pm a   -> pm : allPm a

size :: Blessings String -> Int
size = \case
  Empty      -> 1
  Plain _    -> 1
  SGR _ a    -> 1 + size a
  Append a b -> 1 + size a + size b

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

prop_normalize_preserves_sem :: Blessings String -> Bool
prop_normalize_preserves_sem x =
  sem (normalize x) == sem x

prop_normalize_idempotent :: Blessings String -> Bool
prop_normalize_idempotent x =
  normalize (normalize x) == normalize x

prop_no_unproductive_sgrs :: Blessings String -> Bool
prop_no_unproductive_sgrs x =
  all productive (allSgrNodes (normalize x))
  where
    productive (st, pm) = pmHasVisibleEffect st pm

prop_sgr_params_canonical :: Blessings String -> Bool
prop_sgr_params_canonical x =
  all (\pm -> pm == normalizePm pm) (allPm (normalize x))
  where
    normalizePm pm = styleToPm (applyPm defaultStyle pm)

prop_no_resets :: Blessings String -> Bool
prop_no_resets x =
  all (not . elem 0) (allPm (normalize x))

prop_pmHasVisibleEffect_correct :: Style -> [Word8] -> Bool
prop_pmHasVisibleEffect_correct st pm =
  pmHasVisibleEffect st pm == (applyPm st pm /= st)

prop_normalize_shrinks_or_equal :: Blessings String -> Bool
prop_normalize_shrinks_or_equal x =
  size (normalize x) <= size x

prop_append_sem_associative
  :: Blessings String -> Blessings String -> Blessings String -> Bool
prop_append_sem_associative a b c =
  sem (Append (Append a b) c) == sem (Append a (Append b c))

--------------------------------------------------------------------------------
-- Test runner
--------------------------------------------------------------------------------

spec :: Spec
spec = do
  describe "normalize" $ do
    it "preserves semantics" $
      property prop_normalize_preserves_sem

    it "is idempotent" $
      property prop_normalize_idempotent

    it "never increases size" $
      property prop_normalize_shrinks_or_equal

    it "removes all unproductive SGRs" $
      property prop_no_unproductive_sgrs

    it "produces canonical SGR parameter lists" $
      property prop_sgr_params_canonical

    it "produces no resets" $
      property prop_no_resets

  describe "SGR semantics" $ do
    it "pmHasVisibleEffect matches style change" $
      property prop_pmHasVisibleEffect_correct

  describe "Append" $ do
    it "is associative under semantics" $
      property prop_append_sem_associative