From 47bbaf19c18a62644459f241066c40eb3e8b4fe2 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Fri, 12 Apr 2024 13:36:08 +0700 Subject: [PATCH 1/7] Add benchmarks for semigroup methods. --- benchmarks/haskell/Benchmarks/Pure.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/benchmarks/haskell/Benchmarks/Pure.hs b/benchmarks/haskell/Benchmarks/Pure.hs index b411c17d..d2c7102e 100644 --- a/benchmarks/haskell/Benchmarks/Pure.hs +++ b/benchmarks/haskell/Benchmarks/Pure.hs @@ -26,6 +26,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Encoding as TL +import Data.Semigroup +import Data.List.NonEmpty (NonEmpty((:|))) data Env = Env { bsa :: !BS.ByteString @@ -83,6 +85,14 @@ benchmark kind ~Env{..} = [ benchT $ nf T.concat tl , benchTL $ nf TL.concat tll ] + , bgroup "sconcat" + [ benchT $ nf sconcat (T.empty :| tl) + , benchTL $ nf sconcat (TL.empty :| tll) + ] + , bgroup "stimes" + [ benchT $ nf (stimes (10 :: Int)) ta + , benchTL $ nf (stimes (10 :: Int)) tla + ] , bgroup "cons" [ benchT $ nf (T.cons c) ta , benchTL $ nf (TL.cons c) tla From 866e585f96ab3dc09f2a644e7d05c19a3ca466be Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Fri, 12 Apr 2024 13:36:32 +0700 Subject: [PATCH 2/7] Add specialized implementation of semigroup methods. --- src/Data/Text.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index 09da02ac..a3baa358 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -372,6 +372,8 @@ instance Read Text where -- | @since 1.2.2.0 instance Semigroup Text where (<>) = append + stimes = replicate . P.fromIntegral + sconcat = concat . NonEmptyList.toList instance Monoid Text where mempty = empty From f7e1089998a01034e866459c5ae057b51a6553d1 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Sat, 13 Apr 2024 15:56:20 +0700 Subject: [PATCH 3/7] Check that `stimes` works right in corner cases. --- tests/Tests/Properties.hs | 2 ++ tests/Tests/Properties/CornerCases.hs | 35 +++++++++++++++++++++++++++ text.cabal | 1 + 3 files changed, 38 insertions(+) create mode 100644 tests/Tests/Properties/CornerCases.hs diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs index a01f4058..095e33f1 100644 --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -17,6 +17,7 @@ import Tests.Properties.Read (testRead) import Tests.Properties.Text (testText) import Tests.Properties.Transcoding (testTranscoding) import Tests.Properties.Validate (testValidate) +import Tests.Properties.CornerCases (testCornerCases) tests :: TestTree tests = @@ -30,5 +31,6 @@ tests = testBuilder, testLowLevel, testRead, + testCornerCases, testValidate ] diff --git a/tests/Tests/Properties/CornerCases.hs b/tests/Tests/Properties/CornerCases.hs new file mode 100644 index 00000000..a6ea48b3 --- /dev/null +++ b/tests/Tests/Properties/CornerCases.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | Check that the definitions that are partial crash in the expected ways or +-- return sensible defaults. +module Tests.Properties.CornerCases (testCornerCases) where + +import Control.Exception +import Data.Either +import Data.Semigroup +import Data.Text +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Tests.QuickCheckUtils () + +testCornerCases :: TestTree +testCornerCases = + testGroup + "corner cases" + [ testGroup + "stimes" + $ let specimen = stimes :: Integer -> Text -> Text + in [ testProperty + "given a negative number, return empty text" + $ \(Negative number) text -> specimen number text == "" + , testProperty + "given a number that does not fit into Int, evaluate to error call" + $ \(NonNegative number) text -> + (ioProperty . fmap isLeft . try @ErrorCall . evaluate) $ + specimen + (fromIntegral (number :: Int) + fromIntegral (maxBound :: Int) + 1) + text + ] + ] diff --git a/text.cabal b/text.cabal index 168febea..3205bae2 100644 --- a/text.cabal +++ b/text.cabal @@ -284,6 +284,7 @@ test-suite tests Tests.Properties.Substrings Tests.Properties.Text Tests.Properties.Transcoding + Tests.Properties.CornerCases Tests.Properties.Validate Tests.QuickCheckUtils Tests.RebindableSyntaxTest From e22e8d61374f30b5ceb29e3d9f6dfe9e55677c13 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Sat, 13 Apr 2024 16:03:27 +0700 Subject: [PATCH 4/7] Make sure `stimes` works right in corner cases. --- src/Data/Text.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index a3baa358..f790a2ca 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -272,7 +272,8 @@ import Data.Word (Word8) import Foreign.C.Types import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt) import qualified GHC.Exts as Exts -import GHC.Int (Int8) +import GHC.Int (Int8, Int (I#)) +import GHC.Num.Integer (Integer(IS, IP, IN)) import GHC.Stack (HasCallStack) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH @@ -372,7 +373,14 @@ instance Read Text where -- | @since 1.2.2.0 instance Semigroup Text where (<>) = append - stimes = replicate . P.fromIntegral + + -- | Beware: this function will evaluate to error if the given number does + -- not fit into an @Int@. + stimes howManyTimes = case P.toInteger howManyTimes of + IS howManyTimesInt# -> replicate (I# howManyTimesInt#) + IP _ -> P.error "Data.Text.stimes: given number does not fit into an Int!" + IN _ -> P.const empty + sconcat = concat . NonEmptyList.toList instance Monoid Text where From 37f2221d5e917e246e875504a25b2e0bc11390ba Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Sat, 13 Apr 2024 16:33:32 +0700 Subject: [PATCH 5/7] Be abstract of the implementation of `Integer`. The constructors of `Integer` and the module they are exported from all changed between GHC 8 and 9. --- src/Data/Text.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index f790a2ca..329109ba 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -272,8 +272,7 @@ import Data.Word (Word8) import Foreign.C.Types import GHC.Base (eqInt, neInt, gtInt, geInt, ltInt, leInt) import qualified GHC.Exts as Exts -import GHC.Int (Int8, Int (I#)) -import GHC.Num.Integer (Integer(IS, IP, IN)) +import GHC.Int (Int8) import GHC.Stack (HasCallStack) import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH @@ -376,10 +375,11 @@ instance Semigroup Text where -- | Beware: this function will evaluate to error if the given number does -- not fit into an @Int@. - stimes howManyTimes = case P.toInteger howManyTimes of - IS howManyTimesInt# -> replicate (I# howManyTimesInt#) - IP _ -> P.error "Data.Text.stimes: given number does not fit into an Int!" - IN _ -> P.const empty + stimes howManyTimes = + let howManyTimesInt = P.fromIntegral howManyTimes :: Int + in if P.fromIntegral howManyTimesInt == howManyTimes + then replicate howManyTimesInt + else P.error "Data.Text.stimes: given number does not fit into an Int!" sconcat = concat . NonEmptyList.toList From 4e2599f93e6e3ee9f3ce2c18af9012ee844d8ec9 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Mon, 21 Apr 2025 17:23:40 +0700 Subject: [PATCH 6/7] Make `stimes` crash on negative numbers. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why? Li-yao Xia explains: > 1. Asking to "replicate a string n times" with negative n is nonsense. > There must be an error in the definition of n, so throwing an > exception lets users be aware of that error and fix it. > 2. The default definition of `stimes` already throws an exception for `n > <= 0`. People haven't complained about it. Extending the definition > for `n = 0` is reasonable for a monoid. > 3. There could still be a case made in favor of making `stimes` less > partial and more similar to `replicate` (I think "replicate a string > n times" is nonsense as a sentence in natural language, but I don't > have a strong argument that code must follow natural language). Until > someone makes a good case for extending `stimes`, throwing an > exception for negative arguments is forward-compatible: we can extend > the function later (it would only break code that catches the > exception, a fishy thing to do). If we made it total now and changed > our minds later, that would be a more breaking change. https://github.com/haskell/text/pull/580#discussion_r1568667448 --- src/Data/Text.hs | 4 +++- tests/Tests/Properties/CornerCases.hs | 8 ++++++-- tests/Tests/Properties/Instances.hs | 5 +++++ 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index 329109ba..b28ceb4e 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -375,7 +375,9 @@ instance Semigroup Text where -- | Beware: this function will evaluate to error if the given number does -- not fit into an @Int@. - stimes howManyTimes = + stimes howManyTimes + | howManyTimes < 0 = P.error "Data.Text.stimes: given number is negative!" + | otherwise = let howManyTimesInt = P.fromIntegral howManyTimes :: Int in if P.fromIntegral howManyTimesInt == howManyTimes then replicate howManyTimesInt diff --git a/tests/Tests/Properties/CornerCases.hs b/tests/Tests/Properties/CornerCases.hs index a6ea48b3..4774cd51 100644 --- a/tests/Tests/Properties/CornerCases.hs +++ b/tests/Tests/Properties/CornerCases.hs @@ -22,8 +22,12 @@ testCornerCases = "stimes" $ let specimen = stimes :: Integer -> Text -> Text in [ testProperty - "given a negative number, return empty text" - $ \(Negative number) text -> specimen number text == "" + "given a negative number, evaluate to error call" + $ \(Negative number) text -> + (ioProperty . fmap isLeft . try @ErrorCall . evaluate) $ + specimen + (fromIntegral (number :: Int)) + text , testProperty "given a number that does not fit into Int, evaluate to error call" $ \(NonNegative number) text -> diff --git a/tests/Tests/Properties/Instances.hs b/tests/Tests/Properties/Instances.hs index 8f120653..f4971408 100644 --- a/tests/Tests/Properties/Instances.hs +++ b/tests/Tests/Properties/Instances.hs @@ -7,6 +7,7 @@ module Tests.Properties.Instances ) where import Data.Binary (encode, decodeOrFail) +import Data.Semigroup import Data.String (IsString(fromString)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -37,6 +38,9 @@ t_Show = show `eq` (show . T.pack) tl_Show = show `eq` (show . TL.pack) t_mappend s = mappend s`eqP` (unpackS . mappend (T.pack s)) tl_mappend s = mappend s`eqP` (unpackS . mappend (TL.pack s)) +t_stimes = \ number -> eq + ((stimes :: Int -> String -> String) number . unSqrt) + (unpackS . (stimes :: Int -> T.Text -> T.Text) number . T.pack . unSqrt) t_mconcat = (mconcat . unSqrt) `eq` (unpackS . mconcat . L.map T.pack . unSqrt) tl_mconcat = (mconcat . unSqrt) `eq` (unpackS . mconcat . L.map TL.pack . unSqrt) t_mempty = mempty === (unpackS (mempty :: T.Text)) @@ -71,6 +75,7 @@ testInstances = testProperty "tl_Show" tl_Show, testProperty "t_mappend" t_mappend, testProperty "tl_mappend" tl_mappend, + testProperty "t_stimes" t_stimes, testProperty "t_mconcat" t_mconcat, testProperty "tl_mconcat" tl_mconcat, testProperty "t_mempty" t_mempty, From 9f63f10993f1e76bf55ed636bc00e341c3cb22a0 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Mon, 21 Apr 2025 18:02:21 +0700 Subject: [PATCH 7/7] Move the crash warning to the instance haddock. Haddock does not support comments on instance methods. https://github.com/haskell/haddock/issues/123 --- src/Data/Text.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index b28ceb4e..21458522 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -370,11 +370,12 @@ instance Read Text where readsPrec p str = [(pack x,y) | (x,y) <- readsPrec p str] -- | @since 1.2.2.0 +-- +-- Beware: @stimes@ will crash if the given number does not fit into +-- an @Int@. instance Semigroup Text where (<>) = append - -- | Beware: this function will evaluate to error if the given number does - -- not fit into an @Int@. stimes howManyTimes | howManyTimes < 0 = P.error "Data.Text.stimes: given number is negative!" | otherwise =