text-builder-dev 0.3.3.2 → 0.3.4
raw patch · 8 files changed
+485/−257 lines, 8 filesdep +base-compatdep +quickcheck-classesdep +timedep ~QuickCheckdep ~quickcheck-instances
Dependencies added: base-compat, quickcheck-classes, time
Dependency ranges changed: QuickCheck, quickcheck-instances
Files
- benchmark-char/Main.hs +11/−10
- benchmark-text/Main.hs +19/−15
- library/TextBuilderDev.hs +102/−41
- library/TextBuilderDev/Allocator.hs +70/−0
- library/TextBuilderDev/Prelude.hs +5/−3
- test/Main.hs +171/−120
- test/TextBuilderDev/TastyExtras.hs +13/−15
- text-builder-dev.cabal +94/−53
benchmark-char/Main.hs view
@@ -7,20 +7,21 @@ import qualified TextBuilderDev as A import Prelude +main :: IO () main =- defaultMain $- [ subjectBenchmark "builderSubject" builderSubject,- subjectBenchmark "lazyTextBuilderDevSubject" lazyTextBuilderDevSubject,- subjectBenchmark "plainTextPackingSubject" plainTextPackingSubject- ]+ defaultMain+ $ [ subjectBenchmark "builderSubject" builderSubject,+ subjectBenchmark "lazyTextBuilderDevSubject" lazyTextBuilderDevSubject,+ subjectBenchmark "plainTextPackingSubject" plainTextPackingSubject+ ] subjectBenchmark :: String -> Subject -> Benchmark subjectBenchmark title subject =- bgroup title $- [ benchmark "Small input" smallInput subject,- benchmark "Medium input" mediumInput subject,- benchmark "Large input" largeInput subject- ]+ bgroup title+ $ [ benchmark "Small input" smallInput subject,+ benchmark "Medium input" mediumInput subject,+ benchmark "Large input" largeInput subject+ ] benchmark :: String -> [Int] -> Subject -> Benchmark benchmark title input subject =
benchmark-text/Main.hs view
@@ -1,24 +1,24 @@ module Main where import Criterion.Main-import qualified Data.Text as D import qualified Data.Text.Lazy as C import qualified Data.Text.Lazy.Builder as B import qualified TextBuilderDev as A import Prelude +main :: IO () main =- defaultMain $- [ subjectBenchmark "builderSubject" builderSubject,- subjectBenchmark "lazyTextBuilderDevSubject" lazyTextBuilderDevSubject- ]+ defaultMain+ $ [ subjectBenchmark "builderSubject" builderSubject,+ subjectBenchmark "lazyTextBuilderDevSubject" lazyTextBuilderDevSubject+ ] subjectBenchmark :: String -> Subject -> Benchmark subjectBenchmark title subject =- bgroup title $- [ benchmark "Small input" smallSample subject,- benchmark "Large input" largeSample subject- ]+ bgroup title+ $ [ benchmark "Small input" smallSample subject,+ benchmark "Large input" largeSample subject+ ] benchmark :: String -> Sample -> Subject -> Benchmark benchmark title sample subject =@@ -41,13 +41,17 @@ {-# NOINLINE smallSample #-} smallSample :: Sample smallSample (Subject text (<>) mempty run) =- run $- text "abcd" <> (text "ABCD" <> text "Фываолдж") <> text "漢"+ run+ $ text "abcd"+ <> (text "ABCD" <> text "Фываолдж")+ <> text "漢" {-# NOINLINE largeSample #-} largeSample :: Sample largeSample (Subject text (<>) mempty run) =- run $- foldl' (<>) mempty $- replicate 100000 $- text "abcd" <> (text "ABCD" <> text "Фываолдж") <> text "漢"+ run+ $ foldl' (<>) mempty+ $ replicate 100000+ $ text "abcd"+ <> (text "ABCD" <> text "Фываолдж")+ <> text "漢"
library/TextBuilderDev.hs view
@@ -45,6 +45,7 @@ -- *** Decimal decimal, unsignedDecimal,+ fixedUnsignedDecimal, thousandSeparatedDecimal, thousandSeparatedUnsignedDecimal, dataSizeInBytesInDecimal,@@ -52,6 +53,7 @@ -- *** Binary unsignedBinary, unsignedPaddedBinary,+ finiteBitsUnsignedBinary, -- *** Hexadecimal hexadecimal,@@ -66,6 +68,7 @@ doublePercent, -- ** Time+ utcTimeInIso8601, utcTimestampInIso8601, intervalInSeconds, @@ -81,6 +84,7 @@ import qualified Data.Text.Lazy as TextLazy import qualified Data.Text.Lazy.Builder as TextLazyBuilder import qualified DeferredFolds.Unfoldr as Unfoldr+import qualified Test.QuickCheck.Gen as QcGen import qualified TextBuilderDev.Allocator as Allocator import TextBuilderDev.Prelude hiding (intercalate, length, null) @@ -149,6 +153,8 @@ TextBuilder (allocator1 <> allocator2) (sizeInChars1 + sizeInChars2)+ stimes n (TextBuilder allocator size) =+ TextBuilder (stimes n allocator) (size * fromIntegral n) instance Monoid TextBuilder where {-# INLINE mempty #-}@@ -163,6 +169,41 @@ instance Eq TextBuilder where (==) = on (==) buildText +instance Arbitrary TextBuilder where+ arbitrary =+ QcGen.oneof+ [ QcGen.scale (flip div 2)+ $ QcGen.oneof+ [ (<>) <$> arbitrary <*> arbitrary,+ sconcat <$> arbitrary,+ stimes <$> arbitrary @Word8 <*> arbitrary,+ pure mempty,+ mconcat <$> arbitrary+ ],+ text <$> arbitrary,+ lazyText <$> arbitrary,+ string <$> arbitrary,+ asciiByteString . ByteString.filter (< 128) <$> arbitrary,+ hexData <$> arbitrary,+ char <$> arbitrary,+ decimal @Integer <$> arbitrary,+ unsignedDecimal @Natural <$> arbitrary,+ thousandSeparatedDecimal @Integer <$> arbitrary <*> arbitrary,+ thousandSeparatedUnsignedDecimal @Natural <$> arbitrary <*> arbitrary,+ dataSizeInBytesInDecimal @Natural <$> arbitrary <*> arbitrary,+ unsignedBinary @Natural <$> arbitrary,+ unsignedPaddedBinary @Word <$> arbitrary,+ finiteBitsUnsignedBinary @Word <$> arbitrary,+ hexadecimal @Integer <$> arbitrary,+ unsignedHexadecimal @Natural <$> arbitrary,+ decimalDigit <$> QcGen.choose (0, 9),+ hexadecimalDigit <$> QcGen.choose (0, 15),+ fixedDouble <$> QcGen.choose (0, 19) <*> arbitrary,+ doublePercent <$> QcGen.choose (0, 19) <*> arbitrary,+ utcTimestampInIso8601 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary,+ intervalInSeconds @Double <$> arbitrary+ ]+ instance IsomorphicTo TextBuilder TextBuilder where to = id @@ -315,7 +356,7 @@ -- | Decimal representation of an integral value. {-# INLINEABLE decimal #-}-decimal :: Integral a => a -> TextBuilder+decimal :: (Integral a) => a -> TextBuilder decimal i = if i >= 0 then unsignedDecimal i@@ -323,13 +364,17 @@ -- | Decimal representation of an unsigned integral value. {-# INLINEABLE unsignedDecimal #-}-unsignedDecimal :: Integral a => a -> TextBuilder+unsignedDecimal :: (Integral a) => a -> TextBuilder unsignedDecimal =- foldMap decimalDigit . Unfoldr.decimalDigits+ foldMap (decimalDigit . fromIntegral) . Unfoldr.decimalDigits +fixedUnsignedDecimal :: (Integral a) => Int -> a -> TextBuilder+fixedUnsignedDecimal size val =+ TextBuilder (Allocator.fixedUnsignedDecimal size val) size+ -- | Decimal representation of an integral value with thousands separated by the specified character. {-# INLINEABLE thousandSeparatedDecimal #-}-thousandSeparatedDecimal :: Integral a => Char -> a -> TextBuilder+thousandSeparatedDecimal :: (Integral a) => Char -> a -> TextBuilder thousandSeparatedDecimal separatorChar a = if a >= 0 then thousandSeparatedUnsignedDecimal separatorChar a@@ -337,14 +382,14 @@ -- | Decimal representation of an unsigned integral value with thousands separated by the specified character. {-# INLINEABLE thousandSeparatedUnsignedDecimal #-}-thousandSeparatedUnsignedDecimal :: Integral a => Char -> a -> TextBuilder+thousandSeparatedUnsignedDecimal :: (Integral a) => Char -> a -> TextBuilder thousandSeparatedUnsignedDecimal separatorChar = processRightmostDigit where processRightmostDigit value = case divMod value 10 of (value, digit) ->- processAnotherDigit [decimalDigit digit] 1 value+ processAnotherDigit [decimalDigit (fromIntegral digit)] 1 value processAnotherDigit builders index value = if value == 0 then mconcat builders@@ -353,18 +398,18 @@ if mod index 3 == 0 then processAnotherDigit- (decimalDigit digit : char separatorChar : builders)+ (decimalDigit (fromIntegral digit) : char separatorChar : builders) (succ index) value else processAnotherDigit- (decimalDigit digit : builders)+ (decimalDigit (fromIntegral digit) : builders) (succ index) value -- | Data size in decimal notation over amount of bytes. {-# INLINEABLE dataSizeInBytesInDecimal #-}-dataSizeInBytesInDecimal :: Integral a => Char -> a -> TextBuilder+dataSizeInBytesInDecimal :: (Integral a) => Char -> a -> TextBuilder dataSizeInBytesInDecimal separatorChar amount = if amount < 1000 then unsignedDecimal amount <> "B"@@ -391,30 +436,38 @@ then dividedDecimal separatorChar 100000000000000000000 amount <> "ZB" else dividedDecimal separatorChar 100000000000000000000000 amount <> "YB" -dividedDecimal :: Integral a => Char -> a -> a -> TextBuilder+dividedDecimal :: (Integral a) => Char -> a -> a -> TextBuilder dividedDecimal separatorChar divisor n = let byDivisor = div n divisor byExtraTen = div byDivisor 10 remainder = byDivisor - byExtraTen * 10 in if remainder == 0 || byExtraTen >= 10 then thousandSeparatedDecimal separatorChar byExtraTen- else thousandSeparatedDecimal separatorChar byExtraTen <> "." <> decimalDigit remainder+ else thousandSeparatedDecimal separatorChar byExtraTen <> "." <> decimalDigit (fromIntegral remainder) -- | Unsigned binary number. {-# INLINE unsignedBinary #-}-unsignedBinary :: Integral a => a -> TextBuilder+unsignedBinary :: (Integral a) => a -> TextBuilder unsignedBinary =- foldMap decimalDigit . Unfoldr.binaryDigits+ foldMap (decimalDigit . fromIntegral) . Unfoldr.binaryDigits +-- | A less general but faster alternative to 'unsignedBinary'.+finiteBitsUnsignedBinary :: (FiniteBits a) => a -> TextBuilder+finiteBitsUnsignedBinary a =+ TextBuilder allocator size+ where+ allocator = Allocator.finiteBitsUnsignedBinary a+ size = Allocator.sizeBound allocator+ -- | Unsigned binary number. {-# INLINE unsignedPaddedBinary #-} unsignedPaddedBinary :: (Integral a, FiniteBits a) => a -> TextBuilder unsignedPaddedBinary a =- padFromLeft (finiteBitSize a) '0' $ foldMap decimalDigit $ Unfoldr.binaryDigits a+ padFromLeft (finiteBitSize a) '0' $ foldMap (decimalDigit . fromIntegral) $ Unfoldr.binaryDigits a -- | Hexadecimal representation of an integral value. {-# INLINE hexadecimal #-}-hexadecimal :: Integral a => a -> TextBuilder+hexadecimal :: (Integral a) => a -> TextBuilder hexadecimal i = if i >= 0 then unsignedHexadecimal i@@ -422,40 +475,40 @@ -- | Unsigned hexadecimal representation of an integral value. {-# INLINE unsignedHexadecimal #-}-unsignedHexadecimal :: Integral a => a -> TextBuilder+unsignedHexadecimal :: (Integral a) => a -> TextBuilder unsignedHexadecimal =- foldMap hexadecimalDigit . Unfoldr.hexadecimalDigits+ foldMap (hexadecimalDigit . fromIntegral) . Unfoldr.hexadecimalDigits -- | Decimal digit. {-# INLINE decimalDigit #-}-decimalDigit :: Integral a => a -> TextBuilder+decimalDigit :: Int -> TextBuilder decimalDigit n =- unicodeCodePoint (fromIntegral n + 48)+ unicodeCodePoint (n + 48) -- | Hexadecimal digit. {-# INLINE hexadecimalDigit #-}-hexadecimalDigit :: Integral a => a -> TextBuilder+hexadecimalDigit :: Int -> TextBuilder hexadecimalDigit n = if n <= 9- then unicodeCodePoint (fromIntegral n + 48)- else unicodeCodePoint (fromIntegral n + 87)+ then unicodeCodePoint (n + 48)+ else unicodeCodePoint (n + 87) -- | Intercalate builders. {-# INLINE intercalate #-}-intercalate :: Foldable f => TextBuilder -> f TextBuilder -> TextBuilder+intercalate :: (Foldable f) => TextBuilder -> f TextBuilder -> TextBuilder intercalate separator = extract . foldl' step init where init = Product2 False mempty step (Product2 isNotFirst builder) element =- Product2 True $- if isNotFirst+ Product2 True+ $ if isNotFirst then builder <> separator <> element else element extract (Product2 _ builder) = builder -- | Intercalate projecting values to builder. {-# INLINE intercalateMap #-}-intercalateMap :: Foldable f => TextBuilder -> (a -> TextBuilder) -> f a -> TextBuilder+intercalateMap :: (Foldable f) => TextBuilder -> (a -> TextBuilder) -> f a -> TextBuilder intercalateMap separator mapper = extract . foldl' step init where init = Nothing@@ -483,6 +536,14 @@ then builder else builder <> foldMap char (replicate (paddedLength - builderLength) paddingChar) +utcTimeInIso8601 :: UTCTime -> TextBuilder+utcTimeInIso8601 UTCTime {..} =+ let (year, month, day) = toGregorian utctDay+ daySeconds = round utctDayTime+ (dayMinutes, second) = divMod daySeconds 60+ (hour, minute) = divMod dayMinutes 60+ in utcTimestampInIso8601 (fromIntegral year) month day hour minute second+ -- | -- General template for formatting date values according to the ISO8601 standard. -- The format is the following:@@ -506,17 +567,17 @@ TextBuilder utcTimestampInIso8601 y mo d h mi s = mconcat- [ padFromLeft 4 '0' $ decimal y,+ [ fixedUnsignedDecimal 4 y, "-",- padFromLeft 2 '0' $ decimal mo,+ fixedUnsignedDecimal 2 mo, "-",- padFromLeft 2 '0' $ decimal d,+ fixedUnsignedDecimal 2 d, "T",- padFromLeft 2 '0' $ decimal h,+ fixedUnsignedDecimal 2 h, ":",- padFromLeft 2 '0' $ decimal mi,+ fixedUnsignedDecimal 2 mi, ":",- padFromLeft 2 '0' $ decimal s,+ fixedUnsignedDecimal 2 s, "Z" ] @@ -524,20 +585,20 @@ -- Time interval in seconds. -- Directly applicable to 'DiffTime' and 'NominalDiffTime'. {-# INLINEABLE intervalInSeconds #-}-intervalInSeconds :: RealFrac seconds => seconds -> TextBuilder+intervalInSeconds :: (RealFrac seconds) => seconds -> TextBuilder intervalInSeconds interval = flip evalState (round interval) $ do seconds <- state (swap . flip divMod 60) minutes <- state (swap . flip divMod 60) hours <- state (swap . flip divMod 24) days <- get- return $- padFromLeft 2 '0' (decimal days)- <> ":"- <> padFromLeft 2 '0' (decimal hours)- <> ":"- <> padFromLeft 2 '0' (decimal minutes)- <> ":"- <> padFromLeft 2 '0' (decimal seconds)+ return+ $ padFromLeft 2 '0' (decimal days)+ <> ":"+ <> padFromLeft 2 '0' (decimal hours)+ <> ":"+ <> padFromLeft 2 '0' (decimal minutes)+ <> ":"+ <> padFromLeft 2 '0' (decimal seconds) -- | Double with a fixed number of decimal places. {-# INLINE fixedDouble #-}
library/TextBuilderDev/Allocator.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-unused-imports #-} module TextBuilderDev.Allocator ( -- * Execution allocate,+ sizeBound, -- * Definition Allocator,@@ -17,6 +19,8 @@ utf8CodeUnits4, utf16CodeUnits1, utf16CodeUnits2,+ finiteBitsUnsignedBinary,+ fixedUnsignedDecimal, ) where @@ -42,6 +46,15 @@ ArrayWriter $ \array offset -> do offsetAfter1 <- writeL array offset writeR array offsetAfter1+ stimes n (ArrayWriter write) =+ ArrayWriter $ \array ->+ let go n offset =+ if n > 0+ then do+ offset <- write array offset+ go (pred n) offset+ else return offset+ in go n instance Monoid ArrayWriter where {-# INLINE mempty #-}@@ -58,6 +71,9 @@ frozenArray <- TextArray.unsafeFreeze array return $ TextInternal.text frozenArray 0 offsetAfter +sizeBound :: Allocator -> Int+sizeBound (Allocator _ sizeBound) = sizeBound+ -- | -- Specification of how to efficiently construct strict 'Text'. -- Provides instances of 'Semigroup' and 'Monoid', which have complexity of /O(1)/.@@ -73,6 +89,10 @@ where writer = writer1 <> writer2 estimatedArraySize = estimatedArraySize1 + estimatedArraySize2+ stimes n (Allocator writer sizeBound) =+ Allocator+ (stimes n writer)+ (sizeBound * fromIntegral n) instance Monoid Allocator where {-# INLINE mempty #-}@@ -88,6 +108,11 @@ force :: Allocator -> Allocator force = text . allocate +{-# INLINE sizedWriter #-}+sizedWriter :: Int -> (forall s. TextArray.MArray s -> Int -> ST s Int) -> Allocator+sizedWriter size write =+ Allocator (ArrayWriter write) size+ -- | Strict text. {-# INLINEABLE text #-} text :: Text -> Allocator@@ -243,3 +268,48 @@ TextArray.unsafeWrite array (succ offset) unit2 return $ offset + 2 #endif++-- | A less general but faster alternative to 'unsignedBinary'.+finiteBitsUnsignedBinary :: (FiniteBits a) => a -> Allocator+finiteBitsUnsignedBinary val =+ Allocator writer size+ where+ writer =+ ArrayWriter $ \array arrayStartIndex ->+ let go val arrayIndex =+ if arrayIndex >= arrayStartIndex+ then do+ TextArray.unsafeWrite array arrayIndex+ $ if testBit val 0 then 49 else 48+ go (unsafeShiftR val 1) (pred arrayIndex)+ else return indexAfter+ indexAfter =+ arrayStartIndex + size+ in go val (pred indexAfter)+ size =+ max 1 (finiteBitSize val - countLeadingZeros val)++-- | Fixed-length decimal.+-- Padded with zeros or trimmed depending on whether it's shorter or longer+-- than specified.+fixedUnsignedDecimal :: (Integral a) => Int -> a -> Allocator+fixedUnsignedDecimal size val =+ sizedWriter size $ \array startOffset ->+ let offsetAfter = startOffset + size+ writeValue val offset =+ if offset >= startOffset+ then+ if val /= 0+ then case divMod val 10 of+ (val, digit) -> do+ TextArray.unsafeWrite array offset $ 48 + fromIntegral digit+ writeValue val (pred offset)+ else writePadding offset+ else return offsetAfter+ writePadding offset =+ if offset >= startOffset+ then do+ TextArray.unsafeWrite array offset 48+ writePadding (pred offset)+ else return offsetAfter+ in writeValue val (pred offsetAfter)
library/TextBuilderDev/Prelude.hs view
@@ -30,7 +30,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports+import Data.Functor as Exports hiding (unzip) import Data.Functor.Identity as Exports import Data.IORef as Exports import Data.Int as Exports@@ -45,6 +45,7 @@ import Data.Semigroup as Exports import Data.String as Exports import Data.Text as Exports (Text)+import Data.Time as Exports import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports@@ -63,6 +64,7 @@ import GHC.IO.Exception as Exports import IsomorphismClass as Exports import Numeric as Exports+import Numeric.Natural as Exports (Natural) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -71,8 +73,8 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports-import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Test.QuickCheck.Arbitrary as Exports+import Test.QuickCheck.Instances () import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports
test/Main.hs view
@@ -3,151 +3,202 @@ import qualified Data.ByteString as ByteString import qualified Data.Char as Char import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as TextLazy import qualified Data.Text.Lazy.Builder as TextLazyBuilder-import Test.QuickCheck.Instances+import Numeric.Compat+import Test.QuickCheck.Classes+import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding ((.&.)) import qualified TextBuilderDev as B import qualified TextBuilderDev.TastyExtras as Extras-import Prelude hiding (choose)+import Prelude hiding (choose, showBin) +main :: IO () main =- defaultMain $- testGroup "All tests" $- [ testProperty "ASCII ByteString" $- let gen = listOf $ do- list <- listOf (choose (0, 127))- return (ByteString.pack list)- in forAll gen $ \chunks ->- mconcat chunks- === Text.encodeUtf8 (B.buildText (foldMap B.asciiByteString chunks)),- testProperty "Intercalation has the same effect as in Text" $- \separator texts ->+ defaultMain+ $ testGroup "All tests"+ $ [ testProperty "ASCII ByteString"+ $ let gen = listOf $ do+ list <- listOf (choose (0, 127))+ return (ByteString.pack list)+ in forAll gen $ \chunks ->+ mconcat chunks+ === Text.encodeUtf8 (B.buildText (foldMap B.asciiByteString chunks)),+ testProperty "Intercalation has the same effect as in Text"+ $ \separator texts -> Text.intercalate separator texts === B.buildText (B.intercalate (B.text separator) (fmap B.text texts)),- testProperty "intercalateMap sep mapper == intercalate sep . fmap mapper" $- \separator ints ->+ testProperty "intercalateMap sep mapper == intercalate sep . fmap mapper"+ $ \separator ints -> Text.intercalate separator (fmap (fromString . show @Int) ints) === B.buildText (B.intercalateMap (B.text separator) B.decimal ints),- testProperty "Packing a list of chars is isomorphic to appending a list of builders" $- \chars ->+ testProperty "Packing a list of chars is isomorphic to appending a list of builders"+ $ \chars -> Text.pack chars === B.buildText (foldMap B.char chars),- testProperty "Concatting a list of texts is isomorphic to fold-mapping with builders" $- \texts ->+ testProperty "Concatting a list of texts is isomorphic to fold-mapping with builders"+ $ \texts -> mconcat texts === B.buildText (foldMap B.text texts),- testProperty "Concatting a list of texts is isomorphic to concatting a list of builders" $- \texts ->+ testProperty "Concatting a list of texts is isomorphic to concatting a list of builders"+ $ \texts -> mconcat texts === B.buildText (mconcat (map B.text texts)),- testProperty "Concatting a list of trimmed texts is isomorphic to concatting a list of builders" $- \texts ->+ testProperty "Concatting a list of trimmed texts is isomorphic to concatting a list of builders"+ $ \texts -> let trimmedTexts = fmap (Text.drop 3) texts in mconcat trimmedTexts === B.buildText (mconcat (map B.text trimmedTexts)),- testProperty "Decimal" $ \(x :: Integer) ->- (fromString . show) x === (B.buildText (B.decimal x)),- testProperty "Hexadecimal vs std show" $ \(x :: Integer) ->- x >= 0 ==>- (fromString . showHex x) "" === (B.buildText . B.hexadecimal) x, testProperty "TextBuilderDev.null is isomorphic to Text.null" $ \(text :: Text) -> B.null (B.toTextBuilder text) === Text.null text,- testProperty "(TextBuilderDev.unicodeCodePoint <>) is isomorphic to Text.cons" $- withMaxSuccess bigTest $ \(text :: Text) (c :: Char) ->+ testProperty "(TextBuilderDev.unicodeCodePoint <>) is isomorphic to Text.cons"+ $ withMaxSuccess bigTest+ $ \(text :: Text) (c :: Char) -> B.buildText (B.unicodeCodePoint (Char.ord c) <> B.text text) === Text.cons c text,- testProperty "(TextBuilderDev.utf8CodeUnitsN <>) is isomorphic to Text.cons" $- withMaxSuccess bigTest $ \(text :: Text) (c :: Char) ->- let cp = Char.ord c- cuBuilder- | cp < 0x80 = B.utf8CodeUnits1 (cuAt 0)- | cp < 0x800 = B.utf8CodeUnits2 (cuAt 0) (cuAt 1)- | cp < 0x10000 = B.utf8CodeUnits3 (cuAt 0) (cuAt 1) (cuAt 2)- | otherwise = B.utf8CodeUnits4 (cuAt 0) (cuAt 1) (cuAt 2) (cuAt 3)- where- -- Use Data.Text.Encoding for comparison- codeUnits = Text.encodeUtf8 $ Text.singleton c- cuAt = (codeUnits `ByteString.index`)- in B.buildText (cuBuilder <> B.text text) === Text.cons c text,- testProperty "TextBuilderDev.utf8CodeUnitsN is isomorphic to Text.singleton" $- withMaxSuccess bigTest $ \(c :: Char) ->- let text = Text.singleton c- codeUnits = Text.encodeUtf8 text- cp = Char.ord c- cuBuilder- | cp < 0x80 = B.utf8CodeUnits1 (cuAt 0)- | cp < 0x800 = B.utf8CodeUnits2 (cuAt 0) (cuAt 1)- | cp < 0x10000 = B.utf8CodeUnits3 (cuAt 0) (cuAt 1) (cuAt 2)- | otherwise = B.utf8CodeUnits4 (cuAt 0) (cuAt 1) (cuAt 2) (cuAt 3)- where- cuAt = ByteString.index codeUnits- in B.buildText cuBuilder === text,- testProperty "(TextBuilderDev.utf16CodeUnitsN <>) is isomorphic to Text.cons" $- withMaxSuccess bigTest $ \(text :: Text) (c :: Char) ->- let cp = Char.ord c- cuBuilder- | cp < 0x10000 = B.utf16CodeUnits1 (cuAt 0)- | otherwise = B.utf16CodeUnits2 (cuAt 0) (cuAt 1)- where- -- Use Data.Text.Encoding for comparison- codeUnits = Text.encodeUtf16LE $ Text.singleton c- cuAt i =- (fromIntegral $ codeUnits `ByteString.index` (2 * i))- .|. ((fromIntegral $ codeUnits `ByteString.index` (2 * i + 1)) `shiftL` 8)- in B.buildText (cuBuilder <> B.text text) === Text.cons c text,- testCase "Separated thousands" $ do- assertEqual "" "0" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 0))- assertEqual "" "123" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 123))- assertEqual "" "1,234" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 1234))- assertEqual "" "1,234,567" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 1234567)),- testCase "Pad from left" $ do- assertEqual "" "00" (B.buildText (B.padFromLeft 2 '0' ""))- assertEqual "" "00" (B.buildText (B.padFromLeft 2 '0' "0"))- assertEqual "" "01" (B.buildText (B.padFromLeft 2 '0' "1"))- assertEqual "" "12" (B.buildText (B.padFromLeft 2 '0' "12"))- assertEqual "" "123" (B.buildText (B.padFromLeft 2 '0' "123")),- testCase "Pad from right" $ do- assertEqual "" "00" (B.buildText (B.padFromRight 2 '0' ""))- assertEqual "" "00" (B.buildText (B.padFromRight 2 '0' "0"))- assertEqual "" "10" (B.buildText (B.padFromRight 2 '0' "1"))- assertEqual "" "12" (B.buildText (B.padFromRight 2 '0' "12"))- assertEqual "" "123" (B.buildText (B.padFromRight 2 '0' "123"))- assertEqual "" "1 " (B.buildText (B.padFromRight 3 ' ' "1")),- testCase "Hexadecimal" $- assertEqual "" "1f23" (B.buildText (B.hexadecimal 0x01f23)),- testCase "Negative Hexadecimal" $- assertEqual "" "-1f23" (B.buildText (B.hexadecimal (-0x01f23))),- testGroup "Time interval" $- [ testCase "59s" $ assertEqual "" "00:00:00:59" $ B.buildText $ B.intervalInSeconds 59,- testCase "minute" $ assertEqual "" "00:00:01:00" $ B.buildText $ B.intervalInSeconds 60,- testCase "90s" $ assertEqual "" "00:00:01:30" $ B.buildText $ B.intervalInSeconds 90,- testCase "hour" $ assertEqual "" "00:01:00:00" $ B.buildText $ B.intervalInSeconds 3600,- testCase "day" $ assertEqual "" "01:00:00:00" $ B.buildText $ B.intervalInSeconds 86400- ],- testCase "dataSizeInBytesInDecimal" $ do- assertEqual "" "999B" (B.buildText (B.dataSizeInBytesInDecimal ',' 999))- assertEqual "" "1kB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1000))- assertEqual "" "1.1kB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1100))- assertEqual "" "1.1MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1150000))- assertEqual "" "9.9MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 9990000))- assertEqual "" "10MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 10100000))- assertEqual "" "1,000YB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1000000000000000000000000000)),- testCase "fixedDouble" $ do- assertEqual "" "0.0" (B.buildText (B.fixedDouble 1 0.05))- assertEqual "" "0.1" (B.buildText (B.fixedDouble 1 0.06))- assertEqual "" "10.0000" (B.buildText (B.fixedDouble 4 10))- assertEqual "" "0.9000" (B.buildText (B.fixedDouble 4 0.9)),- testCase "doublePercent" $ do- assertEqual "" "90.4%" (B.buildText (B.doublePercent 1 0.904)),- testGroup "IsomorphicToTextBuilder" $- [ Extras.isomorphismLaws "Text" $ Proxy @Text,- Extras.isomorphismLaws "Lazy Text" $ Proxy @TextLazy.Text,- Extras.isomorphismLaws "Lazy Text Builder" $ Proxy @TextLazyBuilder.Builder,- Extras.isomorphismLaws "String" $ Proxy @String- ]+ testGroup "Time interval"+ $ [ testCase "59s" $ assertEqual "" "00:00:00:59" $ B.buildText $ B.intervalInSeconds 59,+ testCase "minute" $ assertEqual "" "00:00:01:00" $ B.buildText $ B.intervalInSeconds 60,+ testCase "90s" $ assertEqual "" "00:00:01:30" $ B.buildText $ B.intervalInSeconds 90,+ testCase "hour" $ assertEqual "" "00:01:00:00" $ B.buildText $ B.intervalInSeconds 3600,+ testCase "day" $ assertEqual "" "01:00:00:00" $ B.buildText $ B.intervalInSeconds 86400+ ],+ testGroup "By function name"+ $ [ testGroup "utf8CodeUnitsN"+ $ [ testProperty "Text.cons isomporphism"+ $ withMaxSuccess bigTest+ $ \(text :: Text) (c :: Char) ->+ let cp = Char.ord c+ cuBuilder+ | cp < 0x80 = B.utf8CodeUnits1 (cuAt 0)+ | cp < 0x800 = B.utf8CodeUnits2 (cuAt 0) (cuAt 1)+ | cp < 0x10000 = B.utf8CodeUnits3 (cuAt 0) (cuAt 1) (cuAt 2)+ | otherwise = B.utf8CodeUnits4 (cuAt 0) (cuAt 1) (cuAt 2) (cuAt 3)+ where+ -- Use Data.Text.Encoding for comparison+ codeUnits = Text.encodeUtf8 $ Text.singleton c+ cuAt = (codeUnits `ByteString.index`)+ in B.buildText (cuBuilder <> B.text text) === Text.cons c text,+ testProperty "Text.singleton isomorphism"+ $ withMaxSuccess bigTest+ $ \(c :: Char) ->+ let text = Text.singleton c+ codeUnits = Text.encodeUtf8 text+ cp = Char.ord c+ cuBuilder+ | cp < 0x80 = B.utf8CodeUnits1 (cuAt 0)+ | cp < 0x800 = B.utf8CodeUnits2 (cuAt 0) (cuAt 1)+ | cp < 0x10000 = B.utf8CodeUnits3 (cuAt 0) (cuAt 1) (cuAt 2)+ | otherwise = B.utf8CodeUnits4 (cuAt 0) (cuAt 1) (cuAt 2) (cuAt 3)+ where+ cuAt = ByteString.index codeUnits+ in B.buildText cuBuilder === text+ ],+ testGroup "utf16CodeUnitsN"+ $ [ testProperty "is isomorphic to Text.cons"+ $ withMaxSuccess bigTest+ $ \(text :: Text) (c :: Char) ->+ let cp = Char.ord c+ cuBuilder+ | cp < 0x10000 = B.utf16CodeUnits1 (cuAt 0)+ | otherwise = B.utf16CodeUnits2 (cuAt 0) (cuAt 1)+ where+ -- Use Data.Text.Encoding for comparison+ codeUnits = Text.encodeUtf16LE $ Text.singleton c+ cuAt i =+ (fromIntegral $ codeUnits `ByteString.index` (2 * i))+ .|. ((fromIntegral $ codeUnits `ByteString.index` (2 * i + 1)) `shiftL` 8)+ in B.buildText (cuBuilder <> B.text text) === Text.cons c text+ ],+ testCase "thousandSeparatedUnsignedDecimal" $ do+ assertEqual "" "0" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 0))+ assertEqual "" "123" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 123))+ assertEqual "" "1,234" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 1234))+ assertEqual "" "1,234,567" (B.buildText (B.thousandSeparatedUnsignedDecimal ',' 1234567)),+ testCase "padFromLeft" $ do+ assertEqual "" "00" (B.buildText (B.padFromLeft 2 '0' ""))+ assertEqual "" "00" (B.buildText (B.padFromLeft 2 '0' "0"))+ assertEqual "" "01" (B.buildText (B.padFromLeft 2 '0' "1"))+ assertEqual "" "12" (B.buildText (B.padFromLeft 2 '0' "12"))+ assertEqual "" "123" (B.buildText (B.padFromLeft 2 '0' "123")),+ testCase "padFromRight" $ do+ assertEqual "" "00" (B.buildText (B.padFromRight 2 '0' ""))+ assertEqual "" "00" (B.buildText (B.padFromRight 2 '0' "0"))+ assertEqual "" "10" (B.buildText (B.padFromRight 2 '0' "1"))+ assertEqual "" "12" (B.buildText (B.padFromRight 2 '0' "12"))+ assertEqual "" "123" (B.buildText (B.padFromRight 2 '0' "123"))+ assertEqual "" "1 " (B.buildText (B.padFromRight 3 ' ' "1")),+ testProperty "decimal" $ \(x :: Integer) ->+ (fromString . show) x === (B.buildText (B.decimal x)),+ testGroup "hexadecimal"+ $ [ testProperty "show isomorphism" $ \(x :: Integer) ->+ x >= 0 ==>+ (fromString . showHex x) "" === (B.buildText . B.hexadecimal) x,+ testCase "Positive"+ $ assertEqual "" "1f23" (B.buildText (B.hexadecimal 0x01f23)),+ testCase "Negative"+ $ assertEqual "" "-1f23" (B.buildText (B.hexadecimal (-0x01f23)))+ ],+ testCase "dataSizeInBytesInDecimal" $ do+ assertEqual "" "999B" (B.buildText (B.dataSizeInBytesInDecimal ',' 999))+ assertEqual "" "1kB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1000))+ assertEqual "" "1.1kB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1100))+ assertEqual "" "1.1MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1150000))+ assertEqual "" "9.9MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 9990000))+ assertEqual "" "10MB" (B.buildText (B.dataSizeInBytesInDecimal ',' 10100000))+ assertEqual "" "1,000YB" (B.buildText (B.dataSizeInBytesInDecimal ',' 1000000000000000000000000000)),+ testCase "fixedDouble" $ do+ assertEqual "" "0.0" (B.buildText (B.fixedDouble 1 0.05))+ assertEqual "" "0.1" (B.buildText (B.fixedDouble 1 0.06))+ assertEqual "" "10.0000" (B.buildText (B.fixedDouble 4 10))+ assertEqual "" "0.9000" (B.buildText (B.fixedDouble 4 0.9)),+ testCase "doublePercent" $ do+ assertEqual "" "90.4%" (B.buildText (B.doublePercent 1 0.904)),+ testGroup "unsignedBinary"+ $ [ testProperty "Produces the same output as showBin" $ \(x :: Natural) ->+ fromString (showBin x "")+ === B.buildText (B.unsignedBinary x)+ ],+ testGroup "finiteBitsUnsignedBinary"+ $ [ testProperty "Produces the same output as showBin" $ \(x :: Word) ->+ fromString (showBin x "")+ === B.buildText (B.finiteBitsUnsignedBinary x)+ ],+ testGroup "fixedUnsignedDecimal"+ $ [ testProperty "Same as printf" $ \(size :: Word8, val :: Natural) ->+ let rendered = show val+ renderedLength = length rendered+ intSize = fromIntegral size+ padded =+ if renderedLength > intSize+ then drop (renderedLength - intSize) rendered+ else replicate (intSize - renderedLength) '0' <> rendered+ in fromString padded+ === B.buildText (B.fixedUnsignedDecimal (fromIntegral size) val)+ ],+ testGroup "utcTimeInIso8601"+ $ [ testProperty "Same as iso8601Show" $ \x ->+ let roundedToSecondsTime =+ x {utctDayTime = (fromIntegral . round . utctDayTime) x}+ in (fromString . flip mappend "Z" . take 19 . iso8601Show) roundedToSecondsTime+ === B.buildText (B.utcTimeInIso8601 roundedToSecondsTime)+ ]+ ],+ testGroup "IsomorphicToTextBuilder instances"+ $ [ Extras.isomorphismLaws "Text" $ Proxy @Text,+ Extras.isomorphismLaws "Lazy Text" $ Proxy @TextLazy.Text,+ Extras.isomorphismLaws "Lazy Text Builder" $ Proxy @TextLazyBuilder.Builder,+ Extras.isomorphismLaws "String" $ Proxy @String+ ],+ testLaws $ showLaws (Proxy @B.TextBuilder),+ testLaws $ eqLaws (Proxy @B.TextBuilder),+ testLaws $ semigroupLaws (Proxy @B.TextBuilder),+ testLaws $ monoidLaws (Proxy @B.TextBuilder) ] where bigTest = 10000++testLaws :: Laws -> TestTree+testLaws Laws {..} =+ testProperties lawsTypeclass lawsProperties
test/TextBuilderDev/TastyExtras.hs view
@@ -1,10 +1,9 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module TextBuilderDev.TastyExtras where -import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as TextLazyBuilder-import Test.QuickCheck.Instances import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified TextBuilderDev as B import Prelude hiding (choose)@@ -15,10 +14,6 @@ arbitrary = TextLazyBuilder.fromLazyText <$> arbitrary -instance Arbitrary B.TextBuilder where- arbitrary =- B.lazyText <$> arbitrary- -- * -- isomorphismLaws ::@@ -27,13 +22,16 @@ Proxy a -> TestTree isomorphismLaws subject proxy =- testGroup subject $- [ testProperty "fromTextBuilder . toTextBuilder == id" $- (===)- <$> B.fromTextBuilder . B.toTextBuilder+ testGroup subject+ $ [ testProperty "fromTextBuilder . toTextBuilder == id"+ $ (===)+ <$> B.fromTextBuilder+ . B.toTextBuilder <*> flip asProxyTypeOf proxy,- testProperty "toTextBuilder . fromTextBuilder == id" $- (===)- <$> B.toTextBuilder . flip asProxyTypeOf proxy . B.fromTextBuilder+ testProperty "toTextBuilder . fromTextBuilder == id"+ $ (===)+ <$> B.toTextBuilder+ . flip asProxyTypeOf proxy+ . B.fromTextBuilder <*> id- ]+ ]
text-builder-dev.cabal view
@@ -1,85 +1,126 @@ cabal-version: 3.0--name: text-builder-dev-version: 0.3.3.2-category: Text-synopsis: Edge of developments for "text-builder"+name: text-builder-dev+version: 0.3.4+category: Text, Builders+synopsis: Edge of developments for "text-builder" description: This is a development version of \"text-builder\". All experimentation and feature development happens here. The API can change drastically. For a more stable API use \"text-builder\", which is now just a wrapper over this package.-homepage: https://github.com/nikita-volkov/text-builder-dev-bug-reports: https://github.com/nikita-volkov/text-builder-dev/issues-author: Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>-copyright: (c) 2022, Nikita Volkov-license: MIT-license-file: LICENSE +homepage: https://github.com/nikita-volkov/text-builder-dev+bug-reports: https://github.com/nikita-volkov/text-builder-dev/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2022, Nikita Volkov+license: MIT+license-file: LICENSE+ source-repository head- type: git+ type: git location: git://github.com/nikita-volkov/text-builder-dev.git common base-settings- default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, ViewPatterns- default-language: Haskell2010+ default-extensions:+ NoImplicitPrelude+ NoMonomorphismRestriction+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ LambdaCase+ LiberalTypeSynonyms+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ ParallelListComp+ PatternGuards+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ ViewPatterns + default-language: Haskell2010+ library- import: base-settings- hs-source-dirs: library- exposed-modules:- TextBuilderDev+ import: base-settings+ hs-source-dirs: library+ exposed-modules: TextBuilderDev other-modules: TextBuilderDev.Allocator+ TextBuilderDev.Prelude TextBuilderDev.Unicode TextBuilderDev.Utf16View TextBuilderDev.Utf8View- TextBuilderDev.Prelude+ build-depends:- base >=4.11 && <5,- bytestring >=0.10 && <0.12,- deferred-folds >=0.9.10.1 && <0.10,- isomorphism-class >=0.1.0.1 && <0.2,- split >=0.2.3.4 && <0.3,- text >=1.0 && <3,- transformers >=0.5 && <0.7,+ , base >=4.11 && <5+ , bytestring >=0.10 && <0.12+ , deferred-folds >=0.9.10.1 && <0.10+ , isomorphism-class >=0.1.0.1 && <0.2+ , QuickCheck >=2.14 && <3+ , quickcheck-instances >=0.3.28 && <0.4+ , split >=0.2.3.4 && <0.3+ , text >=1.0 && <3+ , time >=1.12 && <2+ , transformers >=0.5 && <0.7 test-suite test- import: base-settings- type: exitcode-stdio-1.0+ import: base-settings+ type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: Main.hs- other-modules:- TextBuilderDev.TastyExtras+ main-is: Main.hs+ other-modules: TextBuilderDev.TastyExtras build-depends:- QuickCheck >=2.13 && <3,- quickcheck-instances >=0.3.22 && <0.4,- rerebase <2,- tasty >=1.2.3 && <2,- tasty-hunit >=0.10.0.2 && <0.11,- tasty-quickcheck >=0.10.1 && <0.11,- text-builder-dev,+ , base-compat ^>=0.13.1+ , quickcheck-classes >=0.6.5 && <0.7+ , quickcheck-instances >=0.3.28 && <0.4+ , rerebase <2+ , tasty >=1.2.3 && <2+ , tasty-hunit >=0.10.0.2 && <0.11+ , tasty-quickcheck >=0.10.1 && <0.11+ , text-builder-dev benchmark benchmark-text- import: base-settings- type: exitcode-stdio-1.0- ghc-options: -O2+ import: base-settings+ type: exitcode-stdio-1.0+ ghc-options: -O2 hs-source-dirs: benchmark-text- main-is: Main.hs+ main-is: Main.hs build-depends:- criterion >=1.5.13.0 && <2,- rerebase ==1.*,- text-builder-dev,+ , criterion >=1.5.13.0 && <2+ , rerebase >=1 && <2+ , text-builder-dev benchmark benchmark-char- import: base-settings- type: exitcode-stdio-1.0- ghc-options: -O2+ import: base-settings+ type: exitcode-stdio-1.0+ ghc-options: -O2 hs-source-dirs: benchmark-char- main-is: Main.hs+ main-is: Main.hs build-depends:- criterion >=1.5.13.0 && <2,- rerebase ==1.*,- text-builder-dev,+ , criterion >=1.5.13.0 && <2+ , rerebase >=1 && <2+ , text-builder-dev