diff --git a/benchmarks/haskell/Benchmarks/Pure.hs b/benchmarks/haskell/Benchmarks/Pure.hs index b5a31fe8..1a9dad12 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 diff --git a/src/Data/Text.hs b/src/Data/Text.hs index c14abf6e..b5981e2a 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -362,6 +362,16 @@ instance Read Text where instance Semigroup Text where (<>) = append + -- | Beware: this function will evaluate to error if the given number does + -- not fit into an @Int@. + 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 + instance Monoid Text where mempty = empty mappend = (<>) 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 9b10c97c..2e953f4f 100644 --- a/text.cabal +++ b/text.cabal @@ -275,6 +275,7 @@ test-suite tests Tests.Properties.Substrings Tests.Properties.Text Tests.Properties.Transcoding + Tests.Properties.CornerCases Tests.Properties.Validate Tests.QuickCheckUtils Tests.RebindableSyntaxTest