diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2022, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,76 @@ +module Main where + +import Data.Function +import qualified Data.Text.Builder.Linear +import qualified Data.Text.Encoding as D +import qualified Data.Text.Lazy as C +import qualified Data.Text.Lazy.Builder as B +import Test.Tasty.Bench +import qualified TextBuilderCore as A +import Prelude + +main :: IO () +main = + defaultMain + [ bgroup "Features" features, + bgroup "Competition" competition + ] + where + features = + [ bench "text" $ whnf (A.toText . A.text) "фывапролдж", + bench "lazyText" $ whnf (A.toText . A.lazyText) "фывапролдж", + bench "char" $ whnf (A.toText . A.char) 'ф', + bench "unicodeCodepoint" $ whnf (A.toText . A.unicodeCodepoint) 1092 + ] + + competition = + [ bgroup "Left-biased mappend" $ byConcat $ foldl' (<>) mempty, + bgroup "Right-biased mappend" $ byConcat $ foldl' (flip (<>)) mempty, + bgroup "mconcat" $ byConcat $ mconcat + ] + where + byConcat (concat :: forall a. (Monoid a) => [a] -> a) = + [ bgroup "100B" $ byTexts $ replicate 10 "фывапролдж", + bgroup "1kB" $ byTexts $ replicate 100 "фывапролдж", + bgroup "10kB" $ byTexts $ replicate 1_000 "фывапролдж", + bgroup "100kB" $ byTexts $ replicate 10_000 "фывапролдж" + ] + where + byTexts texts = + [ bench + "TextBuilderCore.TextBuilder" + ( whnf + (A.toText . concat) + (fmap A.text texts) + ), + bench + "Data.Text.Encoding.StrictTextBuilder" + ( whnf + (D.strictBuilderToText . concat) + (fmap D.textToStrictBuilder texts) + ), + bench + "Data.Text.Lazy.Builder.Builder" + ( whnf + (C.toStrict . B.toLazyText . concat) + (fmap B.fromText texts) + ), + bench + "Data.Text.Text" + ( whnf + concat + texts + ), + bench + "Data.Text.Lazy.Text" + ( whnf + (C.toStrict . concat) + (fmap C.fromStrict texts) + ), + bench + "Data.Text.Builder.Linear" + ( whnf + (Data.Text.Builder.Linear.runBuilder . concat) + (fmap Data.Text.Builder.Linear.fromText texts) + ) + ] diff --git a/library/TextBuilderCore.hs b/library/TextBuilderCore.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderCore.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module TextBuilderCore + ( TextBuilder (..), + + -- * Destructors + isEmpty, + toText, + + -- * Constructors + + -- ** Text + text, + lazyText, + + -- ** Character + char, + unicodeCodepoint, + + -- ** Primitives + unsafeSeptets, + unsafeReverseSeptets, + ) +where + +import qualified Data.Text as Text +import qualified Data.Text.Array as TextArray +import qualified Data.Text.Internal as TextInternal +import qualified Data.Text.Lazy as TextLazy +import TextBuilderCore.Prelude + +#if MIN_VERSION_text(2,0,0) +import qualified TextBuilderCore.Utf8View as Utf8View +#else +import qualified TextBuilderCore.Utf16View as Utf16View +#endif + +-- | +-- Specification of how to efficiently construct strict 'Text'. +-- +-- For this task it is much more efficient than @Data.Text.Lazy.Builder.'Data.Text.Lazy.Builder.Builder'@ and even the recently introduced @Data.Text.Encoding.'Data.Text.Encoding.StrictTextBuilder'@. +-- +-- Provides instances of 'Semigroup' and 'Monoid', which have complexity of /O(1)/. +data TextBuilder + = TextBuilder + -- | Estimated maximum size of the byte array to allocate. + -- + -- If the builder is empty it must be 0. + -- Otherwise it must be greater than or equal to the amount of bytes to be written. + -- + -- __Warning:__ Due to \"text\" switching from UTF-16 to UTF-8 since version 2, 'Word16' is used as the byte when \"text\" version is <2 and 'Word8' is used when it's >=2. + Int + -- | Function that populates a preallocated byte array of the estimated maximum size specified above provided an offset into it and producing the offset after. + -- + -- __Warning:__ The function must not write outside of the allocated array or bad things will happen to the running app. + -- + -- __Warning:__ Keep in mind that the array is operating on 'Word8' values starting from @text-2.0@, but prior to it it operates on 'Word16'. This is due to the \"text\" library switching from UTF-16 to UTF-8 after version 2. To deal with this you have the following options: + -- + -- 1. Restrict the version of the \"text\" library in your package to @>=2@. + -- + -- 2. Use helpers provided by this library, such as 'unsafeSeptets' and 'unsafeReverseSeptets', which abstract over the differences in the underlying representation. + -- + -- 3. Use CPP to conditionally compile your code for different versions of \"text\". + (forall s. TextArray.MArray s -> Int -> ST s Int) + +instance IsString TextBuilder where + fromString = text . fromString + +instance Show TextBuilder where + show = show . toText + +instance Eq TextBuilder where + (==) = on (==) toText + +instance Semigroup TextBuilder where + {-# INLINE (<>) #-} + (<>) (TextBuilder estimatedArraySizeL writeL) (TextBuilder estimatedArraySizeR writeR) = + TextBuilder + (estimatedArraySizeL + estimatedArraySizeR) + ( \array offset -> do + offsetAfter1 <- writeL array offset + writeR array offsetAfter1 + ) + stimes n (TextBuilder maxSize write) = + TextBuilder + (maxSize * fromIntegral n) + ( \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 TextBuilder where + {-# INLINE mempty #-} + mempty = TextBuilder 0 (const return) + {-# INLINE mconcat #-} + mconcat list = + TextBuilder + (foldl' (\acc (TextBuilder maxSize _) -> acc + maxSize) 0 list) + ( \array -> + let go [] offset = return offset + go (TextBuilder _ write : xs) offset = do + offsetAfter <- write array offset + go xs offsetAfter + in go list + ) + +instance Arbitrary TextBuilder where + arbitrary = text . Text.pack <$> arbitrary + shrink a = text . Text.pack <$> shrink (Text.unpack (toText a)) + +-- * Destructors + +-- | Execute the builder producing a strict text. +toText :: TextBuilder -> Text +toText (TextBuilder maxSize write) = + runST $ do + array <- TextArray.new maxSize + offsetAfter <- write array 0 + frozenArray <- TextArray.unsafeFreeze array + return $ TextInternal.text frozenArray 0 offsetAfter + +-- | Check whether the builder is empty. +{-# INLINE isEmpty #-} +isEmpty :: TextBuilder -> Bool +isEmpty (TextBuilder maxSize _) = maxSize == 0 + +-- * Constructors + +-- | Strict text. +{-# INLINEABLE text #-} +text :: Text -> TextBuilder +#if MIN_VERSION_text(2,0,0) +text (TextInternal.Text array offset length) = + TextBuilder length \builderArray builderOffset -> do + TextArray.copyI length builderArray builderOffset array offset + return $ builderOffset + length +#else +text (TextInternal.Text array offset length) = + TextBuilder length \builderArray builderOffset -> do + let builderOffsetAfter = builderOffset + length + TextArray.copyI builderArray builderOffset array offset builderOffsetAfter + return builderOffsetAfter +#endif + +-- | Lazy text. +{-# INLINE lazyText #-} +lazyText :: TextLazy.Text -> TextBuilder +lazyText = + TextLazy.foldrChunks (mappend . text) mempty + +-- ** Codepoint + +-- | Unicode character. +{-# INLINE char #-} +char :: Char -> TextBuilder +char = unicodeCodepoint . ord + +-- | Safe Unicode codepoint with invalid values replaced by the @�@ char (codepoint @0xfffd@), +-- which is the same as what @Data.Text.'Data.Text.pack'@ does. +{-# INLINE unicodeCodepoint #-} +unicodeCodepoint :: Int -> TextBuilder +unicodeCodepoint = unsafeUnicodeCodepoint . project + where + project x = + if x .&. 0x1ff800 /= 0xd800 + then x + else 0xfffd + +-- | Unicode codepoint. +-- +-- __Warning:__ It is your responsibility to ensure that the codepoint is in proper range, +-- otherwise the produced text will be broken. +-- It must be in the range of 0x0000 to 0x10FFFF. +{-# INLINE unsafeUnicodeCodepoint #-} +unsafeUnicodeCodepoint :: Int -> TextBuilder +#if MIN_VERSION_text(2,0,0) +unsafeUnicodeCodepoint x = + Utf8View.unicodeCodepoint x unsafeUtf8CodeUnits1 unsafeUtf8CodeUnits2 unsafeUtf8CodeUnits3 unsafeUtf8CodeUnits4 +#else +unsafeUnicodeCodepoint x = + Utf16View.unicodeCodepoint x unsafeUtf16CodeUnits1 unsafeUtf16CodeUnits2 +#endif + +-- | Single code-unit UTF-8 character. +unsafeUtf8CodeUnits1 :: Word8 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINEABLE unsafeUtf8CodeUnits1 #-} +unsafeUtf8CodeUnits1 unit1 = + TextBuilder 1 \array offset -> + TextArray.unsafeWrite array offset unit1 + $> succ offset +#else +{-# INLINE unsafeUtf8CodeUnits1 #-} +unsafeUtf8CodeUnits1 unit1 = + Utf16View.utf8CodeUnits1 unit1 unsafeUtf16CodeUnits1 unsafeUtf16CodeUnits2 +#endif + +-- | Double code-unit UTF-8 character. +unsafeUtf8CodeUnits2 :: Word8 -> Word8 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINEABLE unsafeUtf8CodeUnits2 #-} +unsafeUtf8CodeUnits2 unit1 unit2 = + TextBuilder 2 \array offset -> do + TextArray.unsafeWrite array offset unit1 + TextArray.unsafeWrite array (offset + 1) unit2 + return $ offset + 2 +#else +{-# INLINE unsafeUtf8CodeUnits2 #-} +unsafeUtf8CodeUnits2 unit1 unit2 = + Utf16View.utf8CodeUnits2 unit1 unit2 unsafeUtf16CodeUnits1 unsafeUtf16CodeUnits2 +#endif + +-- | Triple code-unit UTF-8 character. +unsafeUtf8CodeUnits3 :: Word8 -> Word8 -> Word8 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINEABLE unsafeUtf8CodeUnits3 #-} +unsafeUtf8CodeUnits3 unit1 unit2 unit3 = + TextBuilder 3 \array offset -> do + TextArray.unsafeWrite array offset unit1 + TextArray.unsafeWrite array (offset + 1) unit2 + TextArray.unsafeWrite array (offset + 2) unit3 + return $ offset + 3 +#else +{-# INLINE unsafeUtf8CodeUnits3 #-} +unsafeUtf8CodeUnits3 unit1 unit2 unit3 = + Utf16View.utf8CodeUnits3 unit1 unit2 unit3 unsafeUtf16CodeUnits1 unsafeUtf16CodeUnits2 +#endif + +-- | UTF-8 character out of 4 code units. +unsafeUtf8CodeUnits4 :: Word8 -> Word8 -> Word8 -> Word8 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINEABLE unsafeUtf8CodeUnits4 #-} +unsafeUtf8CodeUnits4 unit1 unit2 unit3 unit4 = + TextBuilder 4 \array offset -> do + TextArray.unsafeWrite array offset unit1 + TextArray.unsafeWrite array (offset + 1) unit2 + TextArray.unsafeWrite array (offset + 2) unit3 + TextArray.unsafeWrite array (offset + 3) unit4 + return $ offset + 4 +#else +{-# INLINE unsafeUtf8CodeUnits4 #-} +unsafeUtf8CodeUnits4 unit1 unit2 unit3 unit4 = + Utf16View.utf8CodeUnits4 unit1 unit2 unit3 unit4 unsafeUtf16CodeUnits1 unsafeUtf16CodeUnits2 +#endif + +-- | Single code-unit UTF-16 character. +unsafeUtf16CodeUnits1 :: Word16 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINE unsafeUtf16CodeUnits1 #-} +unsafeUtf16CodeUnits1 = unsafeUnicodeCodepoint . fromIntegral +#else +{-# INLINEABLE unsafeUtf16CodeUnits1 #-} +unsafeUtf16CodeUnits1 unit = + TextBuilder 1 \array offset -> + TextArray.unsafeWrite array offset unit + $> succ offset +#endif + +-- | Double code-unit UTF-16 character. +unsafeUtf16CodeUnits2 :: Word16 -> Word16 -> TextBuilder +#if MIN_VERSION_text(2,0,0) +{-# INLINE unsafeUtf16CodeUnits2 #-} +unsafeUtf16CodeUnits2 unit1 unit2 = unsafeUnicodeCodepoint cp + where + cp = (((fromIntegral unit1 .&. 0x3FF) `shiftL` 10) .|. (fromIntegral unit2 .&. 0x3FF)) + 0x10000 +#else +{-# INLINEABLE unsafeUtf16CodeUnits2 #-} +unsafeUtf16CodeUnits2 unit1 unit2 = + TextBuilder 2 \array offset -> do + TextArray.unsafeWrite array offset unit1 + TextArray.unsafeWrite array (succ offset) unit2 + return $ offset + 2 +#endif + +-- * Basic Unsafe Primitives + +-- | +-- Provides a unified way to deal with the byte array regardless of the version of the @text@ library. +-- +-- Keep in mind that prior to @text-2.0@, the array was operating on 'Word16' values due to the library abstracting over @UTF-16@. +-- Starting from @text-2.0@, the array operates on 'Word8' values and the library abstracts over @UTF-8@. +-- +-- This function is useful for building ASCII values. +-- +-- >>> unsafeSeptets 3 (fmap (+48) [1, 2, 3]) +-- "123" +-- +-- >>> unsafeSeptets 4 (fmap (+48) [1, 2, 3]) +-- "123" +{-# INLINE unsafeSeptets #-} +unsafeSeptets :: + -- | Maximum size of the byte array to allocate. + -- + -- Must be greater than or equal to the length of the list. + -- + -- __Warning:__ If it is smaller, bad things will happen. + -- We'll be writing outside of the allocated array. + Int -> + -- | List of bytes to write. + -- + -- __Warning:__ It is your responsibility to ensure that the bytes are smaller than 128. + -- Otherwise the produced text will have a broken encoding. + -- + -- To ensure of optimization kicking in it is advised to construct the list using 'GHC.List.build'. + [Word8] -> + TextBuilder +#if MIN_VERSION_text(2,0,0) +unsafeSeptets maxSize bytes = + TextBuilder + maxSize + ( \array -> + foldr + ( \byte next offset -> do + TextArray.unsafeWrite array offset byte + next (succ offset) + ) + return + bytes + ) +#else +unsafeSeptets maxSize bytes = + TextBuilder + maxSize + ( \array -> + foldr + ( \byte next offset -> do + TextArray.unsafeWrite array offset (fromIntegral byte) + next (succ offset) + ) + return + bytes + ) +#endif + +-- | Same as 'unsafeSeptets', but writes the bytes in reverse order and requires the size to be precise. +-- +-- >>> unsafeReverseSeptets 3 (fmap (+48) [1, 2, 3]) +-- "321" +{-# INLINE unsafeReverseSeptets #-} +unsafeReverseSeptets :: + -- | Precise amount of bytes in the list. + -- + -- Needs to be precise, because writing happens in reverse order. + -- + -- __Warning:__ If it is smaller, bad things will happen. + -- We'll be writing outside of the allocated array. + Int -> + -- | List of bytes to write in reverse order. + -- + -- __Warning:__ It is your responsibility to ensure that the bytes are smaller than 128. + -- Otherwise the produced text will have a broken encoding. + -- + -- To ensure of optimization kicking in it is advised to construct the list using 'GHC.List.build'. + [Word8] -> + TextBuilder +#if MIN_VERSION_text(2,0,0) +unsafeReverseSeptets preciseSize bytes = + TextBuilder + preciseSize + ( \array startOffset -> + let endOffset = startOffset + preciseSize + in foldr + ( \byte next offset -> do + TextArray.unsafeWrite array offset byte + next (pred offset) + ) + (\_ -> return endOffset) + bytes + (pred endOffset) + ) +#else +unsafeReverseSeptets preciseSize bytes = + TextBuilder + preciseSize + ( \array startOffset -> + let endOffset = startOffset + preciseSize + in foldr + ( \byte next offset -> do + TextArray.unsafeWrite array offset (fromIntegral byte) + next (pred offset) + ) + (\_ -> return endOffset) + bytes + (pred endOffset) + ) +#endif diff --git a/library/TextBuilderCore/Prelude.hs b/library/TextBuilderCore/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderCore/Prelude.hs @@ -0,0 +1,71 @@ +module TextBuilderCore.Prelude + ( module Exports, + ) +where + +import Control.Applicative as Exports +import Control.Arrow as Exports +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Control.Monad.ST.Unsafe as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Identity as Exports +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Semigroup as Exports +import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.ForeignPtr.Unsafe as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, sizeOf) +import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic) +import GHC.IO.Exception 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 +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Test.QuickCheck.Arbitrary as Exports +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) diff --git a/library/TextBuilderCore/Utf16View.hs b/library/TextBuilderCore/Utf16View.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderCore/Utf16View.hs @@ -0,0 +1,48 @@ +module TextBuilderCore.Utf16View where + +import TextBuilderCore.Prelude +import qualified TextBuilderCore.Utf16View.Unicode as Unicode + +-- | +-- A matching function, which chooses the continuation to run. +type Utf16View = + forall x. (Word16 -> x) -> (Word16 -> Word16 -> x) -> x + +{-# INLINE char #-} +char :: Char -> Utf16View +char x = + unicodeCodepoint (ord x) + +{-# INLINE unicodeCodepoint #-} +unicodeCodepoint :: Int -> Utf16View +unicodeCodepoint x case1 case2 = + if x < 0x10000 + then case1 (fromIntegral x) + else case2 case2Unit1 case2Unit2 + where + m = + x - 0x10000 + case2Unit1 = + fromIntegral (shiftR m 10 + 0xD800) + case2Unit2 = + fromIntegral ((m .&. 0x3FF) + 0xDC00) + +{-# INLINE utf8CodeUnits1 #-} +utf8CodeUnits1 :: Word8 -> Utf16View +utf8CodeUnits1 x case1 _ = + case1 (fromIntegral x) + +{-# INLINE utf8CodeUnits2 #-} +utf8CodeUnits2 :: Word8 -> Word8 -> Utf16View +utf8CodeUnits2 byte1 byte2 case1 _ = + case1 (shiftL (fromIntegral byte1 - 0xC0) 6 + fromIntegral byte2 - 0x80) + +{-# INLINE utf8CodeUnits3 #-} +utf8CodeUnits3 :: Word8 -> Word8 -> Word8 -> Utf16View +utf8CodeUnits3 byte1 byte2 byte3 = + unicodeCodepoint (Unicode.utf8CodeUnits3 byte1 byte2 byte3) + +{-# INLINE utf8CodeUnits4 #-} +utf8CodeUnits4 :: Word8 -> Word8 -> Word8 -> Word8 -> Utf16View +utf8CodeUnits4 byte1 byte2 byte3 byte4 = + unicodeCodepoint (Unicode.utf8CodeUnits4 byte1 byte2 byte3 byte4) diff --git a/library/TextBuilderCore/Utf16View/Unicode.hs b/library/TextBuilderCore/Utf16View/Unicode.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderCore/Utf16View/Unicode.hs @@ -0,0 +1,22 @@ +-- | +-- Utilities for construction of Unicode codepoints. +module TextBuilderCore.Utf16View.Unicode where + +import TextBuilderCore.Prelude + +{-# INLINE utf8CodeUnits3 #-} +utf8CodeUnits3 :: Word8 -> Word8 -> Word8 -> Int +utf8CodeUnits3 byte1 byte2 byte3 = + shiftL (fromIntegral byte1 - 0xE0) 12 + + shiftL (fromIntegral byte2 - 0x80) 6 + + fromIntegral byte3 + - 0x80 + +{-# INLINE utf8CodeUnits4 #-} +utf8CodeUnits4 :: Word8 -> Word8 -> Word8 -> Word8 -> Int +utf8CodeUnits4 byte1 byte2 byte3 byte4 = + shiftL (fromIntegral byte1 - 0xF0) 18 + + shiftL (fromIntegral byte2 - 0x80) 12 + + shiftL (fromIntegral byte3 - 0x80) 6 + + fromIntegral byte4 + - 0x80 diff --git a/library/TextBuilderCore/Utf8View.hs b/library/TextBuilderCore/Utf8View.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderCore/Utf8View.hs @@ -0,0 +1,33 @@ +module TextBuilderCore.Utf8View where + +import TextBuilderCore.Prelude + +-- | +-- A matching function, which chooses the continuation to run. +type Utf8View = + forall x. + (Word8 -> x) -> + (Word8 -> Word8 -> x) -> + (Word8 -> Word8 -> Word8 -> x) -> + (Word8 -> Word8 -> Word8 -> Word8 -> x) -> + x + +{-# INLINE unicodeCodepoint #-} +unicodeCodepoint :: Int -> Utf8View +unicodeCodepoint x case1 case2 case3 case4 + | x < 0x80 = case1 (fromIntegral x) + | x < 0x800 = + case2 + (fromIntegral $ x `shiftR` 6 .|. 0xC0) + (fromIntegral $ (x .&. 0x3F) .|. 0x80) + | x < 0x10000 = + case3 + (fromIntegral $ x `shiftR` 12 .|. 0xE0) + (fromIntegral $ (x `shiftR` 6) .&. 0x3F .|. 0x80) + (fromIntegral $ (x .&. 0x3F) .|. 0x80) + | otherwise = + case4 + (fromIntegral $ x `shiftR` 18 .|. 0xF0) + (fromIntegral $ (x `shiftR` 12) .&. 0x3F .|. 0x80) + (fromIntegral $ (x `shiftR` 6) .&. 0x3F .|. 0x80) + (fromIntegral $ (x .&. 0x3F) .|. 0x80) diff --git a/test/Features.hs b/test/Features.hs new file mode 100644 --- /dev/null +++ b/test/Features.hs @@ -0,0 +1,59 @@ +module Features (tests) where + +import Control.Monad +import Data.String +import qualified Data.Text as Text +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck +import TextBuilderCore +import Util.TestTrees +import Prelude + +tests :: [TestTree] +tests = + [ testGroup "isEmpty" $ + [ testProperty "Is True for empty string" $ + isEmpty (fromString ""), + testProperty "Is True for mempty" $ + isEmpty (fromString mempty), + testProperty "Is True for (mempty <> mempty)" $ + isEmpty (fromString (mempty <> mempty)), + testProperty "Is isomorphic to Text.null" $ \a -> + isEmpty (text a) === Text.null a + ], + testGroup "toText" $ + [ mapsToMonoid toText + ], + testGroup "text" $ + [ mapsToMonoid text + ], + testGroup "lazyText" $ + [ mapsToMonoid lazyText + ], + testGroup "char" $ + [ mapsToMonoid char + ], + testGroup "unicodeCodepoint" $ + [ mapsToMonoid unicodeCodepoint + ], + testGroup "unsafeSeptets" $ + [ isMonoidWithCustomGen do + maxGenSize <- getSize + maxSize <- chooseInt (0, maxGenSize) + actualSize <- chooseInt (0, maxSize) + septets <- + replicateM actualSize $ + fromIntegral <$> chooseInt (0, 127) + pure (unsafeSeptets maxSize septets) + ], + testGroup "unsafeReverseSeptets" $ + [ isMonoidWithCustomGen do + maxGenSize <- getSize + maxSize <- chooseInt (0, maxGenSize) + septets <- + replicateM maxSize $ + fromIntegral <$> chooseInt (0, 127) + pure (unsafeReverseSeptets maxSize septets) + ] + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,54 @@ +module Main where + +import qualified Data.Char as Char +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Features +import Test.QuickCheck.Classes +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck hiding ((.&.)) +import qualified TextBuilderCore as B +import Util.ExtraInstances () +import Util.TestTrees +import Prelude + +main :: IO () +main = (defaultMain . testGroup "All") tests + +tests :: [TestTree] +tests = + [ testGroup "Legacy" $ + [ testProperty "Packing a list of chars is isomorphic to appending a list of builders" $ + \chars -> + Text.pack chars + === B.toText (foldMap B.char chars), + testProperty "Concatting a list of texts is isomorphic to fold-mapping with builders" $ + \texts -> + mconcat texts + === B.toText (foldMap B.text texts), + testProperty "Concatting a list of texts is isomorphic to concatting a list of builders" $ + \texts -> + mconcat texts + === B.toText (mconcat (map B.text 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.toText (mconcat (map B.text trimmedTexts)), + testProperty "(TextBuilderCore.unicodeCodepoint <>) is isomorphic to Text.cons" $ + withMaxSuccess bigTest $ + \(text :: Text) (c :: Char) -> + B.toText (B.unicodeCodepoint (Char.ord c) <> B.text text) === Text.cons c text + ], + testGroup "Laws" $ + [ followsLaws $ showLaws (Proxy @B.TextBuilder), + followsLaws $ eqLaws (Proxy @B.TextBuilder), + followsLaws $ semigroupLaws (Proxy @B.TextBuilder), + followsLaws $ monoidLaws (Proxy @B.TextBuilder) + ], + testGroup "Features" Features.tests + ] + where + bigTest = 10000 diff --git a/test/Util/ExtraInstances.hs b/test/Util/ExtraInstances.hs new file mode 100644 --- /dev/null +++ b/test/Util/ExtraInstances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Util.ExtraInstances where + +import qualified Data.Text.Lazy.Builder as TextLazyBuilder +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Prelude + +instance Arbitrary TextLazyBuilder.Builder where + arbitrary = + TextLazyBuilder.fromLazyText <$> arbitrary diff --git a/test/Util/TestTrees.hs b/test/Util/TestTrees.hs new file mode 100644 --- /dev/null +++ b/test/Util/TestTrees.hs @@ -0,0 +1,86 @@ +module Util.TestTrees where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid +import Data.Semigroup +import Test.QuickCheck +import Test.QuickCheck.Classes +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.QuickCheck +import Prelude + +-- | Tests mapping from @a@ to @b@ to produce a valid 'Monoid'. +-- +-- Tests the following properties: +-- +-- [/Associative/] +-- @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@ +-- [/Semigroup Concatenation/] +-- @'sconcat' as ≡ 'foldr1' ('<>') as@ +-- [/Times/] +-- @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@ +-- [/Left Identity/] +-- @mappend mempty a ≡ a@ +-- [/Right Identity/] +-- @mappend a mempty ≡ a@ +-- [/Monoid Concatenation/] +-- @mconcat as ≡ foldr mappend mempty as@ +mapsToMonoid :: + forall a b. + (Arbitrary a, Monoid b, Eq b, Show b) => + -- | Embed in monoid. + (a -> b) -> + TestTree +mapsToMonoid embed = + isMonoidWithCustomGen (embed <$> arbitrary) + +-- | Tests mapping from @a@ to @b@ to produce a valid 'Monoid'. +-- +-- Tests the following properties: +-- +-- [/Associative/] +-- @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@ +-- [/Semigroup Concatenation/] +-- @'sconcat' as ≡ 'foldr1' ('<>') as@ +-- [/Times/] +-- @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@ +-- [/Left Identity/] +-- @mappend mempty a ≡ a@ +-- [/Right Identity/] +-- @mappend a mempty ≡ a@ +-- [/Monoid Concatenation/] +-- @mconcat as ≡ foldr mappend mempty as@ +isMonoidWithCustomGen :: + (Monoid a, Eq a, Show a) => + Gen a -> + TestTree +isMonoidWithCustomGen gen = + testGroup + "Monoid" + [ testProperty "Is associative" do + x <- gen + y <- gen + z <- gen + pure (x <> (y <> z) === (x <> y) <> z), + testProperty "Semigroup concatenation" do + xs <- (:|) <$> gen <*> listOf gen + pure (sconcat xs === foldr1 (<>) xs), + testProperty "Times" do + x <- gen + Positive n <- arbitrary + pure (stimes n x === foldr1 (<>) (replicate n x)), + testProperty "Left identity" do + x <- gen + pure (mempty <> x === x), + testProperty "Right identity" do + x <- gen + pure (x <> mempty === x), + testProperty "Monoid concatenation" do + xs <- listOf gen + pure (mconcat xs === foldr mappend mempty xs) + ] + +followsLaws :: Laws -> TestTree +followsLaws Laws {..} = + testProperties lawsTypeclass lawsProperties diff --git a/text-builder-core.cabal b/text-builder-core.cabal new file mode 100644 --- /dev/null +++ b/text-builder-core.cabal @@ -0,0 +1,121 @@ +cabal-version: 3.0 +name: text-builder-core +version: 0.1 +category: Text, Builders +synopsis: Internals of "text-builder" +description: + Core functionality of \"text-builder\" with guts exposed for efficient custom integrations. + + Consider this to be what you'll find in the \"Internal\" modules of packages violating PVP. You'll find more on this in [a blog post](https://nikita-volkov.github.io/internal-convention-is-a-mistake/). + +homepage: https://github.com/nikita-volkov/text-builder-core +bug-reports: https://github.com/nikita-volkov/text-builder-core/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2022, Nikita Volkov +license: MIT +license-file: LICENSE + +source-repository head + type: git + location: https://github.com/nikita-volkov/text-builder-core + +common base + default-language: Haskell2010 + default-extensions: + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + ViewPatterns + +library + import: base + hs-source-dirs: library + exposed-modules: TextBuilderCore + other-modules: + TextBuilderCore.Prelude + TextBuilderCore.Utf16View + TextBuilderCore.Utf16View.Unicode + TextBuilderCore.Utf8View + + build-depends: + QuickCheck >=2.14 && <3, + base >=4.11 && <5, + text >=1.2 && <3, + +test-suite test + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Features + Util.ExtraInstances + Util.TestTrees + + build-depends: + QuickCheck >=2.14 && <3, + base >=4.11 && <5, + quickcheck-classes >=0.6.5 && <0.7, + quickcheck-instances >=0.3.32 && <0.4, + tasty >=1.2.3 && <2, + tasty-quickcheck ^>=0.11, + text >=1.2 && <3, + text-builder-core, + +benchmark bench + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: bench + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -with-rtsopts=-A32m + -with-rtsopts=-T + -fproc-alignment=64 + + main-is: Main.hs + build-depends: + base >=4.11 && <5, + tasty-bench ^>=0.4.1, + text >=2.1.2 && <3, + text-builder-core, + text-builder-linear ^>=0.1.3,