From f8f45c2af5aaeeeb12b8fae8568a307c5d89ef38 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Tue, 23 Nov 2021 15:33:44 -0800 Subject: [PATCH] Remove Monoid and Semigroup instances for Attr and MaybeDefault (relevant to brick/#351) This change removes the aforementioned instances because they were misbehaved; merging Attr and MaybeDefault values with these instances resulted in field value losses. For example, before this change, (defAttr `withForeColor` blue) <> (defAttr `withBackColor` green) would result in just (defAttr `withBackColor` green) because the instances were designed to favor the right-hand arguments' fields even if they had not been explicitly set (a consequence of the MaybeDefault Semigroup instance). While that behavior was sensible specifically in the context of Graphics.Vty.Inline, it wasn't a useful user-facing API and it made for surprising instance behavior. Since there is actually no good way to handle this in a Semigroup instance for Attr -- some choices have to be made about how to merge two attributes' foreground colors, and that won't be much better than what we had -- the instance was just removed. I suspect that the risk of this impacting users negatively is very low, given that the instance behavior was not very useful. --- src/Graphics/Vty/Attributes.hs | 27 --------------------------- src/Graphics/Vty/Inline.hs | 6 +++--- test/VerifyAttributes.hs | 30 ------------------------------ vty.cabal | 27 --------------------------- 4 files changed, 3 insertions(+), 87 deletions(-) delete mode 100644 test/VerifyAttributes.hs diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs index 6cd244b..e3f66fa 100644 --- a/src/Graphics/Vty/Attributes.hs +++ b/src/Graphics/Vty/Attributes.hs @@ -61,9 +61,6 @@ where import Control.DeepSeq import Data.Bits -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup -#endif import Data.Text (Text) import Data.Word import GHC.Generics @@ -116,19 +113,6 @@ data Attr = Attr -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. -instance Semigroup Attr where - attr0 <> attr1 = - Attr ( attrStyle attr0 <> attrStyle attr1 ) - ( attrForeColor attr0 <> attrForeColor attr1 ) - ( attrBackColor attr0 <> attrBackColor attr1 ) - ( attrURL attr0 <> attrURL attr1 ) - -instance Monoid Attr where - mempty = Attr mempty mempty mempty mempty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - -- | Specifies the display attributes such that the final style and -- color values do not depend on the previously applied display -- attribute. The display attributes can still depend on the terminal's @@ -151,17 +135,6 @@ instance (NFData v) => NFData (MaybeDefault v) where rnf KeepCurrent = () rnf (SetTo v) = rnf v -instance Semigroup (MaybeDefault v) where - _ <> v@(SetTo _) = v - x <> KeepCurrent = x - _ <> Default = Default - -instance Monoid ( MaybeDefault v ) where - mempty = KeepCurrent -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - -- | Styles are represented as an 8 bit word. Each bit in the word is 1 -- if the style attribute assigned to that bit should be applied and 0 -- if the style attribute should not be applied. diff --git a/src/Graphics/Vty/Inline.hs b/src/Graphics/Vty/Inline.hs index f869b10..1194ef6 100644 --- a/src/Graphics/Vty/Inline.hs +++ b/src/Graphics/Vty/Inline.hs @@ -56,13 +56,13 @@ data InlineState = -- | Set the background color to the provided 'Color'. backColor :: Color -> InlineM () backColor c = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withBackColor` c) + s { inlineAttr = inlineAttr s `withBackColor` c } -- | Set the foreground color to the provided 'Color'. foreColor :: Color -> InlineM () foreColor c = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withForeColor` c) + s { inlineAttr = inlineAttr s `withForeColor` c } -- | Attempt to change the 'Style' of the following text.. @@ -71,7 +71,7 @@ foreColor c = modify $ \s -> -- produced. The style can still be removed. applyStyle :: Style -> InlineM () applyStyle st = modify $ \s -> - s { inlineAttr = inlineAttr s `mappend` (currentAttr `withStyle` st) + s { inlineAttr = inlineAttr s `withStyle` st } -- | Attempt to remove the specified 'Style' from the display of the diff --git a/test/VerifyAttributes.hs b/test/VerifyAttributes.hs deleted file mode 100644 index 19c9fd9..0000000 --- a/test/VerifyAttributes.hs +++ /dev/null @@ -1,30 +0,0 @@ -module VerifyAttributes where - -import Verify - -import Data.Semigroup((<>)) - -import Graphics.Vty.Attributes(MaybeDefault(Default, KeepCurrent, SetTo)) - -instance Arbitrary a => Arbitrary (MaybeDefault a) where - arbitrary = oneof [pure Default, pure KeepCurrent, SetTo <$> arbitrary] - -oldSem :: MaybeDefault a -> MaybeDefault a -> MaybeDefault a -oldSem Default Default = Default -oldSem Default KeepCurrent = Default -oldSem Default (SetTo v) = SetTo v -oldSem KeepCurrent Default = Default -oldSem KeepCurrent KeepCurrent = KeepCurrent -oldSem KeepCurrent (SetTo v) = SetTo v -oldSem (SetTo _v) Default = Default -oldSem (SetTo v) KeepCurrent = SetTo v -oldSem (SetTo _) (SetTo v) = SetTo v - -sameSemigroupValue :: MaybeDefault Int -> MaybeDefault Int -> Bool -sameSemigroupValue xa xb = xa <> xb == oldSem xa xb - -tests :: IO [Test] -tests = return - [ verify "check that the new Semigroup of MaybeDefault is equivalent to the old one" sameSemigroupValue - ] - diff --git a/vty.cabal b/vty.cabal index 9cd1b8e..b60cb91 100644 --- a/vty.cabal +++ b/vty.cabal @@ -554,33 +554,6 @@ test-suite verify-color-mapping utf8-string >= 0.3 && < 1.1, vector >= 0.7 -test-suite verify-semigroup-maybedefault - default-language: Haskell2010 - default-extensions: ScopedTypeVariables - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyAttributes - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.3, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - mtl >= 1.1.1.0 && < 2.3, - text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, - vector >= 0.7 - - test-suite verify-utf8-width default-language: Haskell2010 default-extensions: ScopedTypeVariables