diff --git a/library/TextBuilderDev.hs b/library/TextBuilderDev.hs --- a/library/TextBuilderDev.hs +++ b/library/TextBuilderDev.hs @@ -12,10 +12,10 @@ putLnToStdOut, putLnToStdErr, - -- * Constructors + -- * Classes + IsomorphicToTextBuilder (..), - -- ** Helper class - ToTextBuilder (..), + -- * Constructors -- ** Builder manipulators force, @@ -82,27 +82,64 @@ import qualified Data.Text.Internal as C import qualified DeferredFolds.Unfoldr as Unfoldr import TextBuilderDev.Prelude hiding (intercalate, length, null) +#if MIN_VERSION_text(2,0,0) +import qualified TextBuilderDev.UTF8 as D +#else import qualified TextBuilderDev.UTF16 as D +#endif +import qualified Data.Text.Lazy as TextLazy +import qualified Data.Text.Lazy.Builder as TextLazyBuilder -- * -- | --- Default conversion to text builder. -class ToTextBuilder a where +-- Evidence that there exists an unambiguous way to convert +-- a type to and from "TextBuilder". +-- +-- Unlike typical conversion classes this class is lawful. +-- The law is: +-- +-- @a == "fromTextBuilder" ("toTextBuilder" a)@ +-- +-- This class does not provide implicit rendering, +-- such as from integer to its decimal representation. +-- It should already be evident that there is multiple ways of +-- how an integer can be represented in a textual form (e.g., hexadecimal). +-- The non-ambiguity is further enforced by the presence of +-- the inverse conversion. +-- In the integer case there is no way to read it +-- from a textual form without a possibility of failing. +-- So that is enough to prove that it's not sufficient. +-- +-- If you're looking for such conversion classes, +-- this library is not a place for them, +-- since there can be infinite amount of flavours of +-- conversions. IOW, they are context-dependent and as such +-- should be defined as part of the domain. +class IsomorphicToTextBuilder a where toTextBuilder :: a -> TextBuilder + fromTextBuilder :: TextBuilder -> a -instance ToTextBuilder TextBuilder where +instance IsomorphicToTextBuilder TextBuilder where toTextBuilder = id + fromTextBuilder = id -instance ToTextBuilder Text where +instance IsomorphicToTextBuilder Text where toTextBuilder = text + fromTextBuilder = buildText -instance ToTextBuilder String where +instance IsomorphicToTextBuilder String where toTextBuilder = fromString + fromTextBuilder = Text.unpack . buildText -instance ToTextBuilder Char where - toTextBuilder = char +instance IsomorphicToTextBuilder TextLazy.Text where + toTextBuilder = text . TextLazy.toStrict + fromTextBuilder = TextLazy.fromStrict . buildText +instance IsomorphicToTextBuilder TextLazyBuilder.Builder where + toTextBuilder = text . TextLazy.toStrict . TextLazyBuilder.toLazyText + fromTextBuilder = TextLazyBuilder.fromText . buildText + -- * -- | @@ -138,15 +175,6 @@ instance Show TextBuilder where show = Text.unpack . buildText -instance FromText TextBuilder where - fromText = text - -instance ToText TextBuilder where - toText = buildText - -instance ToString TextBuilder where - toString = toString . buildText - -- * Accessors -- | Get the amount of characters @@ -198,7 +226,7 @@ -- since it's virtually a single call @memcopy@. {-# INLINE force #-} force :: TextBuilder -> TextBuilder -force = text . toText +force = text . buildText -- | Unicode character {-# INLINE char #-} @@ -206,10 +234,59 @@ char x = unicodeCodePoint (ord x) +#if MIN_VERSION_text(2,0,0) + -- | Unicode code point {-# INLINE unicodeCodePoint #-} unicodeCodePoint :: Int -> TextBuilder unicodeCodePoint x = + D.unicodeCodePoint x utf8CodeUnits1 utf8CodeUnits2 utf8CodeUnits3 utf8CodeUnits4 + +{-# INLINEABLE utf8CodeUnits1 #-} +utf8CodeUnits1 :: Word8 -> TextBuilder +utf8CodeUnits1 unit1 = TextBuilder action 1 1 + where action = Action $ \array offset -> B.unsafeWrite array offset unit1 + +{-# INLINEABLE utf8CodeUnits2 #-} +utf8CodeUnits2 :: Word8 -> Word8 -> TextBuilder +utf8CodeUnits2 unit1 unit2 = TextBuilder action 2 1 + where action = Action $ \array offset -> do + B.unsafeWrite array (offset + 0) unit1 + B.unsafeWrite array (offset + 1) unit2 + +{-# INLINEABLE utf8CodeUnits3 #-} +utf8CodeUnits3 :: Word8 -> Word8 -> Word8 -> TextBuilder +utf8CodeUnits3 unit1 unit2 unit3 = TextBuilder action 3 1 + where action = Action $ \array offset -> do + B.unsafeWrite array (offset + 0) unit1 + B.unsafeWrite array (offset + 1) unit2 + B.unsafeWrite array (offset + 2) unit3 + +{-# INLINEABLE utf8CodeUnits4 #-} +utf8CodeUnits4 :: Word8 -> Word8 -> Word8 -> Word8 -> TextBuilder +utf8CodeUnits4 unit1 unit2 unit3 unit4 = TextBuilder action 4 1 + where action = Action $ \array offset -> do + B.unsafeWrite array (offset + 0) unit1 + B.unsafeWrite array (offset + 1) unit2 + B.unsafeWrite array (offset + 2) unit3 + B.unsafeWrite array (offset + 3) unit4 + +{-# INLINE utf16CodeUnits1 #-} +utf16CodeUnits1 :: Word16 -> TextBuilder +utf16CodeUnits1 = unicodeCodePoint . fromIntegral + +{-# INLINE utf16CodeUnits2 #-} +utf16CodeUnits2 :: Word16 -> Word16 -> TextBuilder +utf16CodeUnits2 unit1 unit2 = unicodeCodePoint cp + where + cp = (((fromIntegral unit1 .&. 0x3FF) `shiftL` 10) .|. (fromIntegral unit2 .&. 0x3FF)) + 0x10000 + +#else + +-- | Unicode code point +{-# INLINE unicodeCodePoint #-} +unicodeCodePoint :: Int -> TextBuilder +unicodeCodePoint x = D.unicodeCodePoint x utf16CodeUnits1 utf16CodeUnits2 -- | Single code-unit UTF-16 character @@ -256,6 +333,8 @@ utf8CodeUnits4 unit1 unit2 unit3 unit4 = D.utf8CodeUnits4 unit1 unit2 unit3 unit4 utf16CodeUnits1 utf16CodeUnits2 +#endif + -- | ASCII byte string {-# INLINEABLE asciiByteString #-} asciiByteString :: ByteString -> TextBuilder @@ -278,7 +357,11 @@ where action = Action $ \builderArray builderOffset -> do +#if MIN_VERSION_text(2,0,0) + B.copyI length builderArray builderOffset array offset +#else B.copyI builderArray builderOffset array offset (builderOffset + length) +#endif -- | String {-# INLINE string #-} diff --git a/library/TextBuilderDev/Prelude.hs b/library/TextBuilderDev/Prelude.hs --- a/library/TextBuilderDev/Prelude.hs +++ b/library/TextBuilderDev/Prelude.hs @@ -44,9 +44,7 @@ import Data.STRef as Exports import Data.Semigroup as Exports import Data.String as Exports -import Data.String.ToString as Exports import Data.Text as Exports (Text) -import Data.Text.Conversions as Exports import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports diff --git a/library/TextBuilderDev/UTF16.hs b/library/TextBuilderDev/UTF16.hs --- a/library/TextBuilderDev/UTF16.hs +++ b/library/TextBuilderDev/UTF16.hs @@ -1,6 +1,7 @@ module TextBuilderDev.UTF16 where import TextBuilderDev.Prelude +import qualified TextBuilderDev.Unicode as Unicode -- | -- A matching function, which chooses the continuation to run. @@ -38,21 +39,10 @@ {-# INLINE utf8CodeUnits3 #-} utf8CodeUnits3 :: Word8 -> Word8 -> Word8 -> UTF16View -utf8CodeUnits3 byte1 byte2 byte3 case1 case2 = - unicodeCodePoint unicode case1 case2 - where - unicode = - shiftL (fromIntegral byte1 - 0xE0) 12 - + shiftL (fromIntegral byte2 - 0x80) 6 - + fromIntegral byte3 - 0x80 +utf8CodeUnits3 byte1 byte2 byte3 = + unicodeCodePoint (Unicode.utf8CodeUnits3 byte1 byte2 byte3) {-# INLINE utf8CodeUnits4 #-} utf8CodeUnits4 :: Word8 -> Word8 -> Word8 -> Word8 -> UTF16View -utf8CodeUnits4 byte1 byte2 byte3 byte4 case1 case2 = - unicodeCodePoint unicode case1 case2 - where - unicode = - shiftL (fromIntegral byte1 - 0xE0) 18 - + shiftL (fromIntegral byte2 - 0x80) 12 - + shiftL (fromIntegral byte3 - 0x80) 6 - + fromIntegral byte4 - 0x80 +utf8CodeUnits4 byte1 byte2 byte3 byte4 = + unicodeCodePoint (Unicode.utf8CodeUnits4 byte1 byte2 byte3 byte4) diff --git a/library/TextBuilderDev/UTF8.hs b/library/TextBuilderDev/UTF8.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderDev/UTF8.hs @@ -0,0 +1,33 @@ +module TextBuilderDev.UTF8 where + +import TextBuilderDev.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/library/TextBuilderDev/Unicode.hs b/library/TextBuilderDev/Unicode.hs new file mode 100644 --- /dev/null +++ b/library/TextBuilderDev/Unicode.hs @@ -0,0 +1,20 @@ +-- | +-- Utilities for construction of Unicode codepoints. +module TextBuilderDev.Unicode where + +import TextBuilderDev.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/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,12 +1,13 @@ module Main where import qualified Data.ByteString as ByteString -import qualified Data.Text as A +import qualified Data.Char as Char +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Test.QuickCheck.Instances import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck hiding ((.&.)) import qualified TextBuilderDev as B import Prelude hiding (choose) @@ -22,11 +23,11 @@ === Text.encodeUtf8 (B.buildText (foldMap B.asciiByteString chunks)), testProperty "Intercalation has the same effect as in Text" $ \separator texts -> - A.intercalate separator texts + Text.intercalate separator texts === B.buildText (B.intercalate (B.text separator) (fmap B.text texts)), testProperty "Packing a list of chars is isomorphic to appending a list of builders" $ \chars -> - A.pack chars + Text.pack chars === B.buildText (foldMap B.char chars), testProperty "Concatting a list of texts is isomorphic to fold-mapping with builders" $ \texts -> @@ -38,7 +39,7 @@ === B.buildText (mconcat (map B.text texts)), testProperty "Concatting a list of trimmed texts is isomorphic to concatting a list of builders" $ \texts -> - let trimmedTexts = fmap (A.drop 3) texts + let trimmedTexts = fmap (Text.drop 3) texts in mconcat trimmedTexts === B.buildText (mconcat (map B.text trimmedTexts)), testProperty "Decimal" $ \(x :: Integer) -> @@ -46,6 +47,50 @@ 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) -> + 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)) @@ -91,3 +136,5 @@ testCase "doublePercent" $ do assertEqual "" "90.4%" (B.buildText (B.doublePercent 1 0.904)) ] + where + bigTest = 10000 diff --git a/text-builder-dev.cabal b/text-builder-dev.cabal --- a/text-builder-dev.cabal +++ b/text-builder-dev.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: text-builder-dev -version: 0.2.1 +version: 0.3 category: Text synopsis: Edge of developments for "text-builder" description: @@ -23,7 +23,7 @@ location: git://github.com/nikita-volkov/text-builder-dev.git common language-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-extensions: BangPatterns, ConstraintKinds, CPP, 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 library @@ -32,16 +32,16 @@ exposed-modules: TextBuilderDev other-modules: + TextBuilderDev.Unicode TextBuilderDev.UTF16 + TextBuilderDev.UTF8 TextBuilderDev.Prelude build-depends: base >=4.11 && <5, bytestring >=0.10 && <0.12, deferred-folds >=0.9.10.1 && <0.10, split >=0.2.3.4 && <0.3, - text >=1 && <2, - text-conversions >=0.3.1 && <0.4, - tostring >=0.2.1.1 && <0.3, + text >=1.0 && <3, transformers >=0.5 && <0.7, test-suite test