packages feed

text-builder-linear 0.1.1.1 → 0.1.2

raw patch · 12 files changed

+957/−146 lines, 12 filesdep ~tasty

Dependency ranges changed: tasty

Files

bench/BenchChar.hs view
@@ -10,8 +10,12 @@ import Data.Char import qualified Data.Text as T import Data.Text.Builder.Linear.Buffer+import qualified Data.Text.Lazy as TL import Data.Text.Lazy (toStrict)+import qualified Data.Text.Lazy.Builder as TB import Data.Text.Lazy.Builder (toLazyText, singleton)+import qualified Data.Text.Internal.Fusion.Common as Fusion+import qualified Data.Text.Internal.Fusion as Fusion import Test.Tasty.Bench  #ifdef MIN_VERSION_text_builder@@ -22,6 +26,10 @@ import qualified ByteString.StrictBuilder #endif +--------------------------------------------------------------------------------+-- Single char+--------------------------------------------------------------------------------+ benchLazyBuilder ∷ Int → T.Text benchLazyBuilder = toStrict . toLazyText . go mempty   where@@ -57,11 +65,11 @@     go !acc 0 = acc     go !acc n = let ch = chr n in go (ch .<| (acc |>. ch)) (n - 1) -benchChar ∷ Benchmark-benchChar = bgroup "Char" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6]+benchSingleChar ∷ Benchmark+benchSingleChar = bgroup "Single" $ map mkGroupChar [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] -mkGroup :: Int → Benchmark-mkGroup n = bgroup (show n)+mkGroupChar :: Int → Benchmark+mkGroupChar n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n   , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder@@ -72,3 +80,162 @@ #endif   , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n   ]++--------------------------------------------------------------------------------+-- Multiple chars+--------------------------------------------------------------------------------++charCount :: Word+charCount = 3++benchCharsLazyBuilder ∷ Int → T.Text+benchCharsLazyBuilder = TL.toStrict . TB.toLazyText . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go (replicateChar ch <> (acc <> replicateChar ch)) (n - 1)++    replicateChar ch = TB.fromText (Fusion.unstream (Fusion.replicateCharI charCount ch))++{- [FIXME] bad performance+benchCharsLazyBuilderBS ∷ Int → B.ByteString+benchCharsLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n =+      let ch = chr n+      in go (replicateChar ch <> (acc <> replicateChar ch)) (n - 1)++    replicateChar ch = stimes charCount (B.charUtf8 ch)+-}++#ifdef MIN_VERSION_text_builder+benchCharsStrictBuilder ∷ Int → T.Text+benchCharsStrictBuilder = Text.Builder.run . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go (replicateChar ch <> (acc <> replicateChar ch)) (n - 1)++    -- [TODO] Is there a better way?+    replicateChar ch = Text.Builder.padFromRight (fromIntegral charCount) ch mempty+#endif++{- [TODO]+#ifdef MIN_VERSION_bytestring_strict_builder+benchCharsStrictBuilderBS ∷ Int → B.ByteString+benchCharsStrictBuilderBS = ByteString.StrictBuilder.builderBytes . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go _ (n - 1)+#endif+-}++benchCharsLinearBuilder ∷ Int → T.Text+benchCharsLinearBuilder m = runBuffer (\b → go b m)+  where+    go ∷ Buffer ⊸ Int → Buffer+    go !acc 0 = acc+    go !acc n = let ch = chr n in go (prependChars charCount ch (appendChars charCount ch acc)) (n - 1)++benchMultipleChars ∷ Benchmark+benchMultipleChars = bgroup "Multiple" $ map mkGroupChars [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6]++mkGroupChars :: Int → Benchmark+mkGroupChars n = bgroup (show n)+  [ bench "Data.Text.Lazy.Builder" $ nf benchCharsLazyBuilder n+  -- , bench "Data.ByteString.Builder" $ nf benchCharsLazyBuilderBS n+#ifdef MIN_VERSION_text_builder+  , bench "Text.Builder" $ nf benchCharsStrictBuilder n+#endif+-- #ifdef MIN_VERSION_bytestring_strict_builder+--   , bench "ByteString.StrictBuilder" $ nf benchCharsStrictBuilderBS n+-- #endif+  , bench "Data.Text.Builder.Linear" $ nf benchCharsLinearBuilder n+  ]++--------------------------------------------------------------------------------+-- Padding+--------------------------------------------------------------------------------++benchPaddingLazyBuilder ∷ Int → T.Text+benchPaddingLazyBuilder = toStrict . toLazyText . go mempty 0+  where+    go !acc !_ 0 = acc+    go !acc l  n =+      let ch = chr n+          !l' = l + 2 * fromIntegral charCount+      in go (withText (T.justifyLeft l' ch)+                      (withText (T.justifyRight (l + fromIntegral charCount) ch) acc))+            l'+            (n - 1)++    withText f = TB.fromText . f . TL.toStrict . TB.toLazyText++{- [TODO]+benchPaddingLazyBuilderBS ∷ Int → B.ByteString+benchPaddingLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go _ (n - 1)+-}++#ifdef MIN_VERSION_text_builder+benchPaddingStrictBuilder ∷ Int → T.Text+benchPaddingStrictBuilder = Text.Builder.run . go mempty 0+  where+    go !acc !_ 0 = acc+    go !acc l  n =+      let ch = chr n+          !l' = l + 2 * fromIntegral charCount+      in go (Text.Builder.padFromRight l' ch (Text.Builder.padFromLeft (l + fromIntegral charCount) ch acc))+            l'+            (n - 1)+#endif++{- [TODO]+#ifdef MIN_VERSION_bytestring_strict_builder+benchPaddingStrictBuilderBS ∷ Int → B.ByteString+benchPaddingStrictBuilderBS = ByteString.StrictBuilder.builderBytes . go mempty+  where+    go !acc 0 = acc+    go !acc n = let ch = chr n in go _ (n - 1)+#endif+-}++benchPaddingLinearBuilder ∷ Int → T.Text+benchPaddingLinearBuilder m = runBuffer (\b → go b 0 m)+  where+    go ∷ Buffer ⊸ Word → Int → Buffer+    go !acc !_ 0 = acc+    go !acc l  n =+      let ch = chr n+          !l' = l + 2 * charCount+      in go (justifyLeft l' ch (justifyRight (l + charCount) ch acc))+            l'+            (n - 1)++benchPadding ∷ Benchmark+benchPadding = bgroup "Padding" $ map mkGroupPadding [1e0, 1e1, 1e2, 1e3, 1e4{-, 1e5, 1e6-}] -- NOTE: too long with 1e5++mkGroupPadding :: Int → Benchmark+mkGroupPadding n = bgroup (show n)+  [ bench "Data.Text.Lazy.Builder" $ nf benchPaddingLazyBuilder n+  -- , bench "Data.ByteString.Builder" $ nf benchPaddingLazyBuilderBS n+#ifdef MIN_VERSION_text_builder+  , bench "Text.Builder" $ nf benchPaddingStrictBuilder n+#endif+-- #ifdef MIN_VERSION_bytestring_strict_builder+--   , bench "ByteString.StrictBuilder" $ nf benchPaddingStrictBuilderBS n+-- #endif+  , bench "Data.Text.Builder.Linear" $ nf benchPaddingLinearBuilder n+  ]++--------------------------------------------------------------------------------+-- All benchmarks+--------------------------------------------------------------------------------++benchChar ∷ Benchmark+benchChar = bgroup "Char"+  [ benchSingleChar+  , benchMultipleChars+  , benchPadding ]+
bench/BenchHexadecimal.hs view
@@ -21,42 +21,50 @@ word :: Word word = 123456789123456789 -benchLazyBuilder ∷ Int → T.Text+benchLazyBuilder ∷ Word → T.Text benchLazyBuilder = toStrict . toLazyText . go mempty   where     go !acc 0 = acc-    go !acc n = let i = fromIntegral n * word in go (hexadecimal i <> (acc <> hexadecimal i)) (n - 1)+    go !acc n = let i = n * word in go (hexadecimal i <> (acc <> hexadecimal i)) (n - 1) -benchLazyBuilderBS ∷ Int → B.ByteString+benchLazyBuilderBS ∷ Word → B.ByteString benchLazyBuilderBS = B.toStrict . B.toLazyByteString . go mempty   where     go !acc 0 = acc-    go !acc n = go (B.wordHex (fromIntegral n) <> (acc <> B.wordHex (fromIntegral n))) (n - 1)+    go !acc n = go (B.wordHex n <> (acc <> B.wordHex n)) (n - 1)  #ifdef MIN_VERSION_text_builder-benchStrictBuilder ∷ Int → T.Text+benchStrictBuilder ∷ Word → T.Text benchStrictBuilder = Text.Builder.run . go mempty   where     go !acc 0 = acc-    go !acc n = let i = fromIntegral n * word in go (Text.Builder.hexadecimal i <> (acc <> Text.Builder.hexadecimal i)) (n - 1)+    go !acc n = let i = n * word in go (Text.Builder.hexadecimal i <> (acc <> Text.Builder.hexadecimal i)) (n - 1) #endif -benchLinearBuilder ∷ Int → T.Text-benchLinearBuilder m = runBuffer (\b → go b m)+benchLinearBuilderWord ∷ Word → T.Text+benchLinearBuilderWord m = runBuffer (\b → go b m)   where+    go ∷ Buffer ⊸ Word → Buffer+    go !acc 0 = acc+    go !acc n = let i = n * word in go (i &<| (acc |>& i)) (n - 1)++benchLinearBuilderInt ∷ Word → T.Text+benchLinearBuilderInt m = runBuffer (\b → go b (fromIntegral m))+  where     go ∷ Buffer ⊸ Int → Buffer     go !acc 0 = acc-    go !acc n = let i = fromIntegral n * word in go (i &<| (acc |>& i)) (n - 1)+    go !acc n = let i = n * fromIntegral word in go (i &<| (acc |>& i)) (n - 1)  benchHexadecimal ∷ Benchmark benchHexadecimal = bgroup "Hexadecimal" $ map mkGroup [1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6] -mkGroup :: Int → Benchmark+mkGroup :: Word → Benchmark mkGroup n = bgroup (show n)   [ bench "Data.Text.Lazy.Builder" $ nf benchLazyBuilder n   , bench "Data.ByteString.Builder" $ nf benchLazyBuilderBS n #ifdef MIN_VERSION_text_builder   , bench "Text.Builder" $ nf benchStrictBuilder n #endif-  , bench "Data.Text.Builder.Linear" $ nf benchLinearBuilder n+  , bench "Data.Text.Builder.Linear (Word)" $ nf benchLinearBuilderWord n+  , bench "Data.Text.Builder.Linear (Int)" $ nf benchLinearBuilderInt n   ]
changelog.md view
@@ -1,3 +1,14 @@+## 0.1.2++* Fix unsound behaviour caused by inlining of `runBuffer` / `runBufferBS`+  and CSE (common subexpression elimination).+* Fix hexadecimal builder, looping on negative inputs.+* Fix decimal builder for non-standard bitness of the input.+* Add `(#<|)` and deprecate `(|>#)`.+* Add `newEmptyBuffer`.+* Add `prependChars` and `appendChars`.+* Add `justifyLeft`, `justifyRight` and `center`.+ ## 0.1.1.1  * Support `text-2.1`.
+ src/Data/Text/Builder/Linear/Array.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}++-- |+-- Copyright:   (c) 2022 Andrew Lelechenko+--              (c) 2023 Pierre Le Marre+-- Licence:     BSD3+-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>+--+-- Low-level routines for 'A.MArray' manipulations.+module Data.Text.Builder.Linear.Array (+  unsafeThaw,+  sizeofByteArray,+  isPinned,+  unsafeTile,+  unsafeReplicate,+) where++import Data.Text.Array qualified as A+import GHC.Exts (Int (..), isByteArrayPinned#, isTrue#, setByteArray#, sizeofByteArray#)+import GHC.ST (ST (..))++#if __GLASGOW_HASKELL__ >= 909+import GHC.Exts (unsafeThawByteArray#)+#else+import GHC.Exts (unsafeCoerce#)+#endif++unsafeThaw ∷ A.Array → ST s (A.MArray s)+#if __GLASGOW_HASKELL__ >= 909+unsafeThaw (A.ByteArray a) = ST $ \s# → case unsafeThawByteArray# a s# of+  (# s'#, ma #) -> (# s'#, A.MutableByteArray ma #)+#else+unsafeThaw (A.ByteArray a) = ST $ \s# →+  (# s#, A.MutableByteArray (unsafeCoerce# a) #)+#endif++sizeofByteArray ∷ A.Array → Int+sizeofByteArray (A.ByteArray a) = I# (sizeofByteArray# a)++isPinned ∷ A.Array → Bool+isPinned (A.ByteArray a) = isTrue# (isByteArrayPinned# a)++-- | Replicate an ASCII character+--+-- __Warning:__ it is the responsibility of the caller to ensure that the 'Int'+-- is a valid ASCII character.+unsafeReplicate+  ∷ A.MArray s+  -- ^ Mutable array+  → Int+  -- ^ Offset+  → Int+  -- ^ Count+  → Int+  -- ^ ASCII character+  → ST s ()+unsafeReplicate (A.MutableByteArray dst#) (I# dstOff#) (I# count#) (I# w#) =+  ST (\s# → (# setByteArray# dst# dstOff# count# w# s#, () #))+{-# INLINE unsafeReplicate #-}++-- | Duplicate a portion of an array in-place.+--+-- Example of use:+--+-- @+-- -- Write @count@ times the char @c@+-- let cLen = utf8Length c; totalLen = cLen * count+-- in unsafeWrite dst dstOff ch *> 'unsafeTile' dst dstOff totalLen cLen+-- @+unsafeTile+  ∷ A.MArray s+  -- ^ Mutable array+  → Int+  -- ^ Start of the portion to duplicate+  → Int+  -- ^ Total length of the duplicate+  → Int+  -- ^ Length of the portion to duplicate+  → ST s ()+unsafeTile dest destOff totalLen = go+  where+    -- Adapted from Data.Text.Array.tile+    go l+      | 2 * l > totalLen = A.copyM dest (destOff + l) dest destOff (totalLen - l)+      | otherwise = A.copyM dest (destOff + l) dest destOff l *> go (2 * l)+{-# INLINE unsafeTile #-}
src/Data/Text/Builder/Linear/Buffer.hs view
@@ -1,32 +1,68 @@ -- | -- Copyright:   (c) 2022 Andrew Lelechenko+--              (c) 2023 Pierre Le Marre -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> -- -- 'Buffer' for strict 'Text', based on linear types. module Data.Text.Builder.Linear.Buffer (+  -- * Type   Buffer,++  -- * Basic interface   runBuffer,   runBufferBS,   dupBuffer,   consumeBuffer,   eraseBuffer,   foldlIntoBuffer,-  (|>),+  newEmptyBuffer,+  (><),++  -- * Single character   (|>.),-  (|>#),-  (<|),   (.<|),++  -- * Multiple characters++  -- ** Character replication+  prependChars,+  appendChars,++  -- ** Text+  (|>),+  (<|),+  (|>…),+  (…<|),++  -- ** Raw 'Addr#'+  (|>#),+  ( #<| ), -- NOTE: extra spaces required because of -XUnboxedTuples   (<|#),-  (><),++  -- * Padding+  justifyLeft,+  justifyRight,+  center,++  -- * Number formatting++  -- ** Decimal   (|>$),   ($<|),-  (|>%),-  (%<|),++  -- ** Hexadecimal++  -- *** Lower-case   (|>&),   (&<|),-  (|>…),-  (…<|),++  -- *** Upper-case and padding+  -- $custom_hexadecimal++  -- ** Double+  (|>%),+  (%<|), ) where  import Data.Text.Array qualified as A@@ -56,7 +92,7 @@     buffer  -- | Prepend 'Text' prefix to a 'Buffer' by mutating it.--- If a prefix is statically known, consider using '(<|#)' for optimal performance.+-- If a prefix is statically known, consider using '(#<|)' for optimal performance. -- -- >>> :set -XOverloadedStrings -XLinearTypes -- >>> runBuffer (\b -> "foo" <| "bar" <| b)@@ -79,8 +115,6 @@ -- -- The literal string must not contain zero bytes @\\0@ and must be a valid UTF-8, -- these conditions are not checked.------ Note the inconsistency in naming: unfortunately, GHC parser does not allow for @#<|@. (|>#) ∷ Buffer ⊸ Addr# → Buffer  infixl 6 |>#@@ -96,15 +130,21 @@ -- to a 'Buffer' by mutating it. E. g., -- -- >>> :set -XOverloadedStrings -XLinearTypes -XMagicHash--- >>> runBuffer (\b -> "foo"# <|# "bar"# <|# b)+-- >>> runBuffer (\b -> "foo"# #<| "bar"# #<| b) -- "foobar" -- -- The literal string must not contain zero bytes @\\0@ and must be a valid UTF-8, -- these conditions are not checked.-(<|#) ∷ Addr# → Buffer ⊸ Buffer+--+-- /Note:/ When the syntactic extensions @UnboxedTuples@ or @UnboxedSums@ are+-- enabled, extra spaces are required when using parentheses: i.e. use @( '#<|' )@+-- instead of @('#<|')@. See the GHC User Guide chapter+-- “[Unboxed types and primitive operations](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/primitives.html#unboxed-tuples)”+-- for further information.+( #<| ) ∷ Addr# → Buffer ⊸ Buffer -infixr 6 <|#-addr# <|# buffer =+infixr 6 #<|, <|#+addr# #<| buffer =   prependExact     srcLen     (\dst dstOff → A.copyFromPointer dst dstOff (Ptr addr#) srcLen)@@ -112,6 +152,12 @@   where     srcLen = I# (cstringLength# addr#) +-- | Alias for @'(#<|)'@.+{-# DEPRECATED (<|#) "Use '(#<|)' instead" #-}+(<|#) ∷ Addr# → Buffer ⊸ Buffer+(<|#) = ( #<| ) -- NOTE: extra spaces required because of -XUnboxedTuples+{-# INLINE (<|#) #-}+ -- | Append given number of spaces. (|>…) ∷ Buffer ⊸ Word → Buffer @@ -152,3 +198,10 @@     go ∷ Buffer ⊸ [a] → Buffer     go !acc [] = acc     go !acc (x : xs) = go (f acc x) xs++-- $custom_hexadecimal+--+-- Note that no /upper/ case hexadecimal formatting is provided. This package+-- provides a minimal API with utility functions only for common cases. For+-- other use cases, please adapt the code of this package, e.g. as shown in+-- the [Unicode code point example](https://github.com/Bodigrim/linear-builder/examples/src/Examples/Unicode.hs).
src/Data/Text/Builder/Linear/Char.hs view
@@ -3,26 +3,43 @@ -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> module Data.Text.Builder.Linear.Char (-  -- * Buffer+  -- * Single character   (|>.),   (.<|),++  -- * Multiple characters+  prependChars,+  appendChars,++  -- * Padding+  justifyLeft,+  justifyRight,+  center, ) where +import Data.Char (isAscii) import Data.Text.Array qualified as A import Data.Text.Internal.Encoding.Utf8 (ord2, ord3, ord4, utf8Length) import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite) import GHC.ST (ST)+import Unsafe.Coerce (unsafeCoerce) +import Data.Text.Builder.Linear.Array (unsafeReplicate, unsafeTile) import Data.Text.Builder.Linear.Core +--------------------------------------------------------------------------------+-- Single char+--------------------------------------------------------------------------------+ -- | Append 'Char' to a 'Buffer' by mutating it. -- -- >>> :set -XLinearTypes -- >>> runBuffer (\b -> b |>. 'q' |>. 'w') -- "qw" ----- In contrast to 'Data.Text.Lazy.Builder.singleton', it's a responsibility--- of the caller to sanitize surrogate code points with 'Data.Text.Internal.safe'.+-- __Warning:__ In contrast to 'Data.Text.Lazy.Builder.singleton', it is the+-- responsibility of the caller to sanitize surrogate code points with+-- 'Data.Text.Internal.safe'. (|>.) ∷ Buffer ⊸ Char → Buffer  infixl 6 |>.@@ -34,8 +51,9 @@ -- >>> runBuffer (\b -> 'q' .<| 'w' .<| b) -- "qw" ----- In contrast to 'Data.Text.Lazy.Builder.singleton', it's a responsibility--- of the caller to sanitize surrogate code points with 'Data.Text.Internal.safe'.+-- __Warning:__ In contrast to 'Data.Text.Lazy.Builder.singleton', it is the+-- responsibility of the caller to sanitize surrogate code points with+-- 'Data.Text.Internal.safe'. (.<|) ∷ Char → Buffer ⊸ Buffer  infixr 6 .<|@@ -72,3 +90,131 @@     A.unsafeWrite marr (off - 2) n2     A.unsafeWrite marr (off - 1) n3     pure 4++--------------------------------------------------------------------------------+-- Multiple chars+--------------------------------------------------------------------------------++-- | Prepend a given count of a 'Char' to a 'Buffer'.+--+-- >>> :set -XLinearTypes+-- >>> runBuffer (\b -> prependChars 3 'x' (b |>. 'A'))+-- "xxxA"+prependChars ∷ Word → Char → Buffer ⊸ Buffer+prependChars count ch buff+  | count == 0 = buff+  | otherwise =+      case utf8Length ch of+        cLen → case cLen * fromIntegral count of+          totalLen →+            prependExact+              totalLen+              ( if isAscii ch+                  then \dst dstOff → unsafeReplicate dst dstOff (fromIntegral count) (ord ch)+                  else \dst dstOff → unsafeWrite dst dstOff ch *> unsafeTile dst dstOff totalLen cLen+              )+              buff++-- | Apppend a given count of a 'Char' to a 'Buffer'.+--+-- >>> :set -XLinearTypes+-- >>> runBuffer (\b -> appendChars 3 'x' (b |>. 'A'))+-- "Axxx"+appendChars ∷ Word → Char → Buffer ⊸ Buffer+appendChars count ch buff+  | count == 0 = buff+  | otherwise =+      case utf8Length ch of+        cLen → case cLen * fromIntegral count of+          totalLen →+            appendExact+              totalLen+              ( if isAscii ch+                  then \dst dstOff → unsafeReplicate dst dstOff (fromIntegral count) (ord ch)+                  else \dst dstOff → unsafeWrite dst dstOff ch *> unsafeTile dst dstOff totalLen cLen+              )+              buff++--------------------------------------------------------------------------------+-- Padding+--------------------------------------------------------------------------------++-- | Pad a builder from the /left/ side to the specified length with the specified+-- character.+--+-- >>> :set -XLinearTypes+-- >>> runBuffer (\b -> justifyRight 10 'x' (appendChars 3 'A' b))+-- "xxxxxxxAAA"+-- >>> runBuffer (\b -> justifyRight 5 'x' (appendChars 6 'A' b))+-- "AAAAAA"+--+-- Note that 'newEmptyBuffer' is needed in some situations. The following example creates+-- a utility function that justify a text and then append it to a buffer.+--+-- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples+-- >>> import Data.Text.Builder.Linear.Buffer+-- >>> import Data.Text (Text)+-- >>> :{+-- appendJustified :: Buffer %1 -> Text -> Buffer+-- appendJustified b t = case newEmptyBuffer b of+--   -- Note that we need to create a new buffer from the text, in order+--   -- to justify only the text and not the input buffer.+--   (# b', empty #) -> b' >< justifyRight 12 ' ' (empty |> t)+-- :}+--+-- >>> runBuffer (\b -> (b |> "Test:") `appendJustified` "foo" `appendJustified` "bar")+-- "Test:         foo         bar"+justifyRight ∷ Word → Char → Buffer ⊸ Buffer+justifyRight n ch buff = case lengthOfBuffer buff of+  (# buff', len #) →+    toLinearWord+      (\l b → if n <= l then b else prependChars (n - l) ch b)+      len+      buff'++-- | Pad a builder from the /right/ side to the specified length with the specified+-- character.+--+-- >>> :set -XLinearTypes+-- >>> runBuffer (\b -> justifyLeft 10 'x' (appendChars 3 'A' b))+-- "AAAxxxxxxx"+-- >>> runBuffer (\b -> justifyLeft 5 'x' (appendChars 6 'A' b))+-- "AAAAAA"+--+-- Note that 'newEmptyBuffer' is needed in some situations. See 'justifyRight'+-- for an example.+justifyLeft ∷ Word → Char → Buffer ⊸ Buffer+justifyLeft n ch buff = case lengthOfBuffer buff of+  (# buff', len #) →+    toLinearWord+      (\l b → if n <= l then b else appendChars (n - l) ch b)+      len+      buff'++-- | Center a builder to the specified length with the specified character.+--+-- >>> :set -XLinearTypes+-- >>> runBuffer (\b -> center 10 'x' (appendChars 3 'A' b))+-- "xxxxAAAxxx"+-- >>> runBuffer (\b -> center 5 'x' (appendChars 6 'A' b))+-- "AAAAAA"+--+-- Note that 'newEmptyBuffer' is needed in some situations. See 'justifyRight'+-- for an example.+center ∷ Word → Char → Buffer ⊸ Buffer+center n ch buff = case lengthOfBuffer buff of+  (# buff', len #) →+    toLinearWord+      ( \l b →+          if n <= l+            then b+            else case n - l of+              !d → case d `quot` 2 of+                !r → appendChars r ch (prependChars (d - r) ch b)+      )+      len+      buff'++-- Despite the use of unsafeCoerce, this is safe.+toLinearWord ∷ (Word → a) → (Word ⊸ a)+toLinearWord = unsafeCoerce
src/Data/Text/Builder/Linear/Core.hs view
@@ -1,11 +1,15 @@ -- | -- Copyright:   (c) 2022 Andrew Lelechenko+--              (c) 2023 Pierre Le Marre -- Licence:     BSD3 -- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com> -- -- Low-level routines for 'Buffer' manipulations. module Data.Text.Builder.Linear.Core (+  -- * Type   Buffer,++  -- * Basic interface   runBuffer,   runBufferBS,   dupBuffer,@@ -15,6 +19,9 @@   lengthOfBuffer,   dropBuffer,   takeBuffer,+  newEmptyBuffer,++  -- * Text concatenation   appendBounded,   appendExact,   prependBounded,@@ -26,10 +33,12 @@ import Data.Text qualified as T import Data.Text.Array qualified as A import Data.Text.Internal (Text (..))-import GHC.Exts (Int (..), Levity (..), RuntimeRep (..), TYPE, byteArrayContents#, isByteArrayPinned#, isTrue#, plusAddr#, sizeofByteArray#, unsafeCoerce#)+import GHC.Exts (Int (..), Levity (..), RuntimeRep (..), TYPE, byteArrayContents#, plusAddr#, unsafeCoerce#) import GHC.ForeignPtr (ForeignPtr (..), ForeignPtrContents (..)) import GHC.ST (ST (..), runST) +import Data.Text.Builder.Linear.Array+ -- | Internally 'Buffer' is a mutable buffer. -- If a client gets hold of a variable of type 'Buffer', -- they'd be able to pass a mutable buffer to concurrent threads.@@ -66,10 +75,10 @@  -- | Run a linear function on an empty 'Buffer', producing a strict 'Text'. ----- Be careful to write @runBuffer (\b -> ...)@ instead of @runBuffer $ \b -> ...@,+-- Be careful to write @runBuffer (\\b -> ...)@ instead of @runBuffer $ \\b -> ...@, -- because current implementation of linear types lacks special support for '($)'. -- Another option is to enable @{-# LANGUAGE BlockArguments #-}@--- and write @runBuffer \b -> ...@.+-- and write @runBuffer \\b -> ...@. -- Alternatively, you can import -- [@($)@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#v:-36-) -- from [@linear-base@](https://hackage.haskell.org/package/linear-base).@@ -83,7 +92,16 @@ -- 'Text' and [@Ur@](https://hackage.haskell.org/package/linear-base-0.3.0/docs/Prelude-Linear.html#t:Ur) 'Text' are equivalent. runBuffer ∷ (Buffer ⊸ Buffer) ⊸ Text runBuffer f = unBuffer (shrinkBuffer (f (Buffer mempty)))+{-# NOINLINE runBuffer #-} +{-+  See https://github.com/Bodigrim/linear-builder/issues/19+  and https://github.com/tweag/linear-base/pull/187#discussion_r489081926+  for the discussion why NOINLINE here and below in 'runBufferBS' is necessary.+  Without it CSE (common subexpression elimination) can pull out 'Buffer's from+  different 'runBuffer's and share them, which is absolutely not what we want.+-}+ -- | Same as 'runBuffer', but returning a UTF-8 encoded strict 'ByteString'. runBufferBS ∷ (Buffer ⊸ Buffer) ⊸ ByteString runBufferBS f = case shrinkBuffer (f (Buffer memptyPinned)) of@@ -91,6 +109,7 @@     where       addr# = byteArrayContents# arr `plusAddr#` from       fp = ForeignPtr addr# (PlainPtr (unsafeCoerce# arr))+{-# NOINLINE runBufferBS #-}  shrinkBuffer ∷ Buffer ⊸ Buffer shrinkBuffer (Buffer (Text arr from len)) = Buffer $ runST $ do@@ -105,6 +124,34 @@   arr ← A.unsafeFreeze marr   pure $ Text arr 0 0 +-- | Create an empty 'Buffer'.+--+-- The first 'Buffer' is the input and the second is a new empty 'Buffer'.+--+-- This function is needed in some situations, e.g. with+-- 'Data.Text.Builder.Linear.Buffer.justifyRight'. The following example creates+-- a utility function that justify a text and then append it to a buffer.+--+-- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples+-- >>> import Data.Text.Builder.Linear.Buffer+-- >>> import Data.Text (Text)+-- >>> :{+-- appendJustified :: Buffer %1 -> Text -> Buffer+-- appendJustified b t = case newEmptyBuffer b of+--   -- Note that we need to create a new buffer from the text, in order+--   -- to justify only the text and not the input buffer.+--   (# b', empty #) -> b' >< justifyRight 12 ' ' (empty |> t)+-- :}+--+-- >>> runBuffer (\b -> (b |> "Test:") `appendJustified` "foo" `appendJustified` "bar")+-- "Test:         foo         bar"+--+-- Note: a previous buffer is necessary in order to create an empty buffer with+-- the same characteristics.+newEmptyBuffer ∷ Buffer ⊸ (# Buffer, Buffer #)+newEmptyBuffer (Buffer t@(Text arr _ _)) =+  (# Buffer t, Buffer (if isPinned arr then memptyPinned else mempty) #)+ -- | Duplicate builder. Feel free to process results in parallel threads. -- Similar to -- [@Dupable@](https://hackage.haskell.org/package/linear-base/docs/Prelude-Linear.html#t:Dupable)@@ -120,7 +167,7 @@ -- -- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples -- >>> import Data.Text.Builder.Linear.Buffer--- >>> runBuffer (\b -> (\(# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) (dupBuffer b))+-- >>> runBuffer (\b -> case dupBuffer b of (# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) -- "foobar" -- -- Note the unboxed tuple: 'Buffer' is an unlifted datatype,@@ -152,9 +199,9 @@ -- import Data.Unrestricted.Linear -- -- dropEndBuffer :: Word -> Buffer %1 -> Buffer--- dropEndBuffer n buf =---   (\(# buf', len #) -> case move len of Ur len' -> takeBuffer (len' - n) buf')---     (lengthOfBuffer buf)+-- dropEndBuffer n buf = case lengthOfBuffer buf of+--   (# buf', len #) -> case move len of+--     Ur len' -> takeBuffer (len' - n) buf' -- @ lengthOfBuffer ∷ Buffer ⊸ (# Buffer, Word #) lengthOfBuffer (Buffer t) = (# Buffer t, fromIntegral (T.length t) #)@@ -242,7 +289,7 @@       pure $ Text new newOff (dstLen + srcLen) {-# INLINE prependBounded #-} --- | Low-level routine to append data of unknown size to a 'Buffer'.+-- | Low-level routine to append data of known size to a 'Buffer'. prependExact   ∷ Int   -- ^ Exact number of bytes, written by an action@@ -257,23 +304,13 @@     (\dst dstOff → appender dst dstOff >> pure srcLen) {-# INLINE prependExact #-} -unsafeThaw ∷ A.Array → ST s (A.MArray s)-unsafeThaw (A.ByteArray a) = ST $ \s# →-  (# s#, A.MutableByteArray (unsafeCoerce# a) #)--sizeofByteArray ∷ A.Array → Int-sizeofByteArray (A.ByteArray a) = I# (sizeofByteArray# a)--isPinned ∷ A.Array → Bool-isPinned (A.ByteArray a) = isTrue# (isByteArrayPinned# a)- -- | Concatenate two 'Buffer's, potentially mutating both of them. -- -- You likely need to use 'dupBuffer' to get hold on two builders at once: -- -- >>> :set -XOverloadedStrings -XLinearTypes -XUnboxedTuples -- >>> import Data.Text.Builder.Linear.Buffer--- >>> runBuffer (\b -> (\(# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) (dupBuffer b))+-- >>> runBuffer (\b -> case dupBuffer b of (# b1, b2 #) -> ("foo" <| b1) >< (b2 |> "bar")) -- "foobar" (><) ∷ Buffer ⊸ Buffer ⊸ Buffer
src/Data/Text/Builder/Linear/Dec.hs view
@@ -66,12 +66,12 @@   where     go ∷ (Integral a, FiniteBits a) ⇒ Int → a → Int     go acc k-      | finiteBitSize k >= 30, k >= 1000000000 = go (acc + 9) (quotBillion k)+      | finiteBitSize k >= if isSigned k then 31 else 30, k >= 1e9 = go (acc + 9) (quotBillion k)       | otherwise = acc + goInt (fromIntegral k)      goInt l@(I# l#)-      | l >= 1e5 = 5 + I# (l# >=# 100000000#) + I# (l# >=# 10000000#) + I# (l# >=# 1000000#)-      | otherwise = I# (l# >=# 10000#) + I# (l# >=# 1000#) + I# (l# >=# 100#) + I# (l# >=# 10#)+      | l >= 1e5 = 5 + I# (l# >=# 100_000_000#) + I# (l# >=# 10_000_000#) + I# (l# >=# 1_000_000#)+      | otherwise = I# (l# >=# 10_000#) + I# (l# >=# 1_000#) + I# (l# >=# 100#) + I# (l# >=# 10#) {-# INLINEABLE exactDecLen #-}  unsafeAppendDec ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int@@ -82,7 +82,7 @@ unsafePrependDec marr !off n   | n < 0   , n == bit (finiteBitSize n - 1) = do-      A.unsafeWrite marr (off - 1) (fromIntegral (48 + minBoundLastDigit n))+      A.unsafeWrite marr (off - 1) (fromIntegral (0x30 + minBoundLastDigit n))       go (off - 2) (abs (bit (finiteBitSize n - 1) `quot` 10)) >>= sign   | n == 0 = do       A.unsafeWrite marr (off - 1) 0x30 >> pure 1@@ -101,15 +101,20 @@           A.copyFromPointer marr (o - 1) (Ptr digits `plusPtr` (fromIntegral r `shiftL` 1)) 2           if k < 100 then pure (o - 1) else go (o - 2) q       | otherwise = do-          A.unsafeWrite marr o (fromIntegral (48 + k))+          A.unsafeWrite marr o (fromIntegral (0x30 + k))           pure o      digits ∷ Addr#     digits = "00010203040506070809101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899"# {-# INLINEABLE unsafePrependDec #-} +-- Compute rem minBound 10 efficiently. Given that:+-- • minBound = 1 `shiftL` (finiteBitSize a - 1) = -2^(finiteBitSize a - 1)+-- • the last digit of 2^k forms a cycle for k≥1: 2,4,8,6+-- Then it is enough to pattern-match rem (finiteBitSize a) 4,+-- i.e. finiteBitSize a .&. 3 minBoundLastDigit ∷ FiniteBits a ⇒ a → Int-minBoundLastDigit a = case finiteBitSize a .&. 4 of+minBoundLastDigit a = case finiteBitSize a .&. 3 of   0 → 8   1 → 6   2 → 2
src/Data/Text/Builder/Linear/Double.hs view
@@ -29,7 +29,7 @@     (\dst dstOff → unsafeAppendDouble dst dstOff x)     buffer --- | Prepend double+-- | Prepend double. (%<|) ∷ Double → Buffer ⊸ Buffer  infixr 6 %<|
src/Data/Text/Builder/Linear/Hex.hs view
@@ -9,34 +9,58 @@  import Data.Bits (Bits (..), FiniteBits (..)) import Data.Text.Array qualified as A+import Data.Word (Word16, Word32, Word64, Word8) import GHC.Exts (Int (..), (>#)) import GHC.ST (ST)  import Data.Text.Builder.Linear.Core --- | Append hexadecimal number.+-- | Append the lower-case hexadecimal represensation of a number.+--+-- Negative numbers are interpreted as their corresponding unsigned number, e.g.+--+-- >>> :set -XOverloadedStrings -XLinearTypes+-- >>> import Data.Int (Int8, Int16)+-- >>> runBuffer (\b -> b |>& (-1 :: Int8)) == "ff"+-- True+-- >>> runBuffer (\b -> b |>& (-1 :: Int16)) == "ffff"+-- True (|>&) ∷ (Integral a, FiniteBits a) ⇒ Buffer ⊸ a → Buffer  infixl 6 |>& buffer |>& n =   appendBounded-    (finiteBitSize n `shiftR` 2)+    (maxHexLen n)     (\dst dstOff → unsafeAppendHex dst dstOff n)     buffer {-# INLINEABLE (|>&) #-} --- | Prepend hexadecimal number.+-- | Prepend the lower-case hexadecimal representation of a number.+--+-- Negative numbers are interpreted as their corresponding unsigned number, e.g.+--+-- >>> :set -XOverloadedStrings -XLinearTypes+-- >>> import Data.Int (Int8, Int16)+-- >>> runBuffer (\b -> (-1 :: Int8) &<| b) == "ff"+-- True+-- >>> runBuffer (\b -> (-1 :: Int16) &<| b) == "ffff"+-- True (&<|) ∷ (Integral a, FiniteBits a) ⇒ a → Buffer ⊸ Buffer  infixr 6 &<| n &<| buffer =   prependBounded-    (finiteBitSize n `shiftR` 2)+    (maxHexLen n)     (\dst dstOff → unsafePrependHex dst dstOff n)     (\dst dstOff → unsafeAppendHex dst dstOff n)     buffer {-# INLINEABLE (&<|) #-} +-- | Compute the number of nibbles that an integral type can hold, rounded up.+maxHexLen ∷ (Integral a, FiniteBits a) ⇒ a → Int+maxHexLen n = 1 + ((finiteBitSize n - 1) `shiftR` 2)+{-# INLINEABLE maxHexLen #-}+ unsafeAppendHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int unsafeAppendHex marr !off 0 =   A.unsafeWrite marr off 0x30 >> pure 1@@ -48,7 +72,7 @@     go !o m = do       let nibble = m .&. 0x0f       writeNibbleAsHex marr o (fromIntegral nibble)-      go (o - 1) (m `shiftR` 4)+      go (o - 1) (dropNibble m) {-# INLINEABLE unsafeAppendHex #-}  unsafePrependHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int@@ -60,12 +84,31 @@     go !o m = do       let nibble = m .&. 0x0f       writeNibbleAsHex marr o (fromIntegral nibble)-      go (o - 1) (m `shiftR` 4)+      go (o - 1) (dropNibble m) {-# INLINEABLE unsafePrependHex #-} --- | This assumes n /= 0.+-- | The usual 'shiftR' performs sign extension on signed number types,+-- filling the top bits with 1 if the argument is negative.+-- We don't want this behaviour here.+--+-- It would suffice to clean the sign bit only once+-- instead of doing it on every iteration of unsafe{Ap,Pre}pernHex.go,+-- but the performance impact is likely negligible.+dropNibble ∷ (Integral a, FiniteBits a) ⇒ a → a+dropNibble x = case (isSigned x, finiteBitSize x) of+  -- This is morally 'iShiftRL#', 'uncheckedIShiftRA64#', etc.,+  -- but there is no polymorphic interface to access them.+  (True, 8) → fromIntegral @Word8 (shiftR (fromIntegral x) 4)+  (True, 16) → fromIntegral @Word16 (shiftR (fromIntegral x) 4)+  (True, 32) → fromIntegral @Word32 (shiftR (fromIntegral x) 4)+  (True, 64) → fromIntegral @Word64 (shiftR (fromIntegral x) 4)+  (True, _) → shiftR x 4 .&. ((1 `shiftL` (finiteBitSize x - 4)) - 1)+  _ → shiftR x 4+{-# INLINE dropNibble #-}++-- | This assumes n /= 0. Round the number of nibbles up, as in 'maxHexLen'. lengthAsHex ∷ FiniteBits a ⇒ a → Int-lengthAsHex n = (finiteBitSize n `shiftR` 2) - (countLeadingZeros n `shiftR` 2)+lengthAsHex n = 1 + shiftR (finiteBitSize n - countLeadingZeros n - 1) 2 {-# INLINEABLE lengthAsHex #-}  writeNibbleAsHex ∷ A.MArray s → Int → Int → ST s ()
test/Main.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+#if __GLASGOW_HASKELL__ >= 907+{-# LANGUAGE TypeAbstractions #-}+#endif+ -- | -- Copyright:   (c) 2022 Andrew Lelechenko -- Licence:     BSD3@@ -5,17 +12,25 @@  module Main where -import Data.Bits (Bits(..), FiniteBits(..))-import Data.Foldable+import Prelude hiding (Foldable(..))+import Data.Bits (Bits(..), FiniteBits(..), bitDefault)+import Data.Foldable (Foldable(..))+import Data.Int+import Data.List (intersperse)+import Data.Proxy (Proxy(..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Text.Builder.Linear.Buffer import Data.Text.Internal (Text(..)) import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder qualified as TB import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat)+import Data.Word import GHC.Generics+import GHC.TypeLits (KnownNat, OrderingI (..), SomeNat (..), cmpNat, natVal, sameNat, someNatVal)+import Numeric.Natural (Natural) import Test.Tasty import Test.Tasty.QuickCheck hiding ((><), (.&.)) @@ -37,12 +52,25 @@   | PrependText Text   | AppendChar Char   | PrependChar Char-  | AppendHex Word-  | PrependHex Word-  | AppendDec Int-  | PrependDec Int-  | AppendDec30 Int30-  | PrependDec30 Int30+  | AppendChars Word Char+  | PrependChars Word Char+  | JustifyLeft Word Char+  | JustifyRight Word Char+  | Center Word Char+  | HexInt Int8 Int16 (IntN 30) (IntN 31) Int32 (IntN 33) Int64+  | HexWord Word8 Word16 Word32 Word64+  | AppendHexI SomeIntN+  | PrependHexI SomeIntN+  | AppendHexW SomeWordN+  | PrependHexW SomeWordN+  | DecInt Int8 Int16 (IntN 30) (IntN 31) Int32 (IntN 33) Int64+  | DecWord Word8 Word16 (WordN 30) (WordN 31) Word32 (WordN 33) Word64+  | AppendDecW Word+  | PrependDecW Word+  | AppendDecI Int+  | PrependDecI Int+  | AppendDecI30 (IntN 30)+  | PrependDecI30 (IntN 30)   | AppendDouble Double   | PrependDouble Double   | AppendSpaces Word@@ -55,61 +83,143 @@     , PrependText   <$> arbitrary     , AppendChar    <$> arbitraryUnicodeChar     , PrependChar   <$> arbitraryUnicodeChar-    , AppendHex     <$> arbitraryBoundedIntegral-    , PrependHex    <$> arbitraryBoundedIntegral-    , AppendDec     <$> arbitraryBoundedIntegral-    , PrependDec    <$> arbitraryBoundedIntegral-    , AppendDec30   <$> arbitraryBoundedIntegral-    , PrependDec30  <$> arbitraryBoundedIntegral-    , pure $ AppendHex minBound-    , pure $ AppendHex maxBound-    , pure $ AppendDec minBound-    , pure $ AppendDec maxBound-    , pure $ AppendDec 0+    , AppendChars   <$> arbitraryCharCount <*> arbitraryUnicodeChar+    , PrependChars  <$> arbitraryCharCount <*> arbitraryUnicodeChar+    , JustifyLeft   <$> arbitraryTotalLength <*> arbitraryUnicodeChar+    , JustifyRight  <$> arbitraryTotalLength <*> arbitraryUnicodeChar+    , Center        <$> arbitraryTotalLength <*> arbitraryUnicodeChar+    , AppendHexI    <$> arbitrary+    , PrependHexI   <$> arbitrary+    , AppendHexW    <$> arbitrary+    , PrependHexW   <$> arbitrary+    , AppendDecW    <$> arbitraryBoundedIntegral+    , PrependDecW   <$> arbitraryBoundedIntegral+    , AppendDecI    <$> arbitraryBoundedIntegral+    , PrependDecI   <$> arbitraryBoundedIntegral+    , AppendDecI30  <$> arbitraryBoundedIntegral+    , PrependDecI30 <$> arbitraryBoundedIntegral+    , pure $ HexWord minBound minBound minBound minBound+    , pure $ HexWord maxBound maxBound maxBound maxBound+    , pure $ HexInt minBound minBound minBound minBound minBound minBound minBound+    , pure $ HexInt maxBound maxBound maxBound maxBound maxBound maxBound maxBound+    , pure $ HexInt 0 0 0 0 0 0 0+    , pure $ DecInt minBound minBound minBound minBound minBound minBound minBound+    , pure $ DecInt maxBound maxBound maxBound maxBound maxBound maxBound maxBound+    , pure $ DecInt 0 0 0 0 0 0 0+    , pure $ DecWord minBound minBound minBound minBound minBound minBound minBound+    , pure $ DecWord maxBound maxBound maxBound maxBound maxBound maxBound maxBound     , AppendDouble  <$> arbitrary     , PrependDouble <$> arbitrary     , AppendSpaces . getNonNegative <$> arbitrary     , PrependSpaces . getNonNegative <$> arbitrary     ]+    where+      arbitraryCharCount = chooseBoundedIntegral (0, 6)+      arbitraryTotalLength = chooseBoundedIntegral (3, 20)+   shrink = genericShrink  interpretOnText ∷ [Action] → Text → Text interpretOnText xs z = foldl' go z xs   where     go ∷ Text → Action → Text-    go b (AppendText    x) = b <> x-    go b (PrependText   x) = x <> b-    go b (AppendChar    x) = T.snoc b x-    go b (PrependChar   x) = T.cons x b-    go b (AppendHex     x) = b <> toStrict (toLazyText (hexadecimal x))-    go b (PrependHex    x) = toStrict (toLazyText (hexadecimal x)) <> b-    go b (AppendDec     x) = b <> toStrict (toLazyText (decimal x))-    go b (PrependDec    x) = toStrict (toLazyText (decimal x)) <> b-    go b (AppendDec30   x) = b <> toStrict (toLazyText (decimal x))-    go b (PrependDec30  x) = toStrict (toLazyText (decimal x)) <> b+    go b (AppendText     x) = b <> x+    go b (PrependText    x) = x <> b+    go b (AppendChar     x) = T.snoc b x+    go b (PrependChar    x) = T.cons x b+    go b (AppendChars  n x) = b <> T.replicate (fromIntegral n) (T.singleton x)+    go b (PrependChars n x) = T.replicate (fromIntegral n) (T.singleton x) <> b+    go b (JustifyLeft  n x) = T.justifyLeft  (fromIntegral n) x b+    go b (JustifyRight n x) = T.justifyRight (fromIntegral n) x b+    go b (Center       n x) = T.center (fromIntegral n) x b+    go b (HexInt r s t u v w x)+      = intersperseText+          [ hexadecimal (fromIntegral @Int16 @Word16 s)+          , hexadecimalI t+          , hexadecimal (fromIntegral @Int64 @Word64 x) ]+      <> b+      <> intersperseText+          [ hexadecimal (fromIntegral @Int8 @Word8 r)+          , hexadecimalI u+          , hexadecimal (fromIntegral @Int32 @Word32 v)+          , hexadecimalI w ]+    go b (HexWord u v w x)+      = intersperseText [hexadecimal u, hexadecimal x]+      <> b+      <> intersperseText [hexadecimal v, hexadecimal w ]+    go b (AppendHexI    x) = b <> toStrict (toLazyText (hexadecimalSI x))+    go b (PrependHexI   x) = toStrict (toLazyText (hexadecimalSI x)) <> b+    go b (AppendHexW    x) = b <> toStrict (toLazyText (hexadecimalSW x))+    go b (PrependHexW   x) = toStrict (toLazyText (hexadecimalSW x)) <> b+    go b (DecInt r s t u v w x)+                           = intersperseText [decimal s, decimal t, decimal x]+                           <> b+                           <> intersperseText [decimal r, decimal u, decimal v, decimal w]+    go b (DecWord r s t u v w x)+                           = intersperseText [decimal s, decimal t, decimal x]+                           <> b+                           <> intersperseText [decimal r, decimal u, decimal v, decimal w]+    go b (AppendDecW    x) = b <> toStrict (toLazyText (decimal x))+    go b (PrependDecW   x) = toStrict (toLazyText (decimal x)) <> b+    go b (AppendDecI    x) = b <> toStrict (toLazyText (decimal x))+    go b (PrependDecI   x) = toStrict (toLazyText (decimal x)) <> b+    go b (AppendDecI30  x) = b <> toStrict (toLazyText (decimal x))+    go b (PrependDecI30 x) = toStrict (toLazyText (decimal x)) <> b     go b (AppendDouble  x) = b <> toStrict (toLazyText (realFloat x))     go b (PrependDouble x) = toStrict (toLazyText (realFloat x)) <> b     go b (AppendSpaces  n) = b <> T.replicate (fromIntegral n) (T.singleton ' ')     go b (PrependSpaces n) = T.replicate (fromIntegral n) (T.singleton ' ') <> b +    hexadecimalSI (SomeIntN x) = hexadecimalI x++    hexadecimalI ∷ (KnownNat n) ⇒ IntN n → TB.Builder+    hexadecimalI x = if x >= 0+      then hexadecimal x+      else hexadecimal (fromIntegral @_ @Word64 x .&. (shiftL 1 (intSize x) - 1))++    hexadecimalSW (SomeWordN x) = hexadecimalW x++    hexadecimalW ∷ (KnownNat n) ⇒ WordN n → TB.Builder+    hexadecimalW x = if x >= 0+      then hexadecimal x+      else hexadecimal (fromIntegral @_ @Word64 x .&. (shiftL 1 (intSize x) - 1))++    intersperseText ∷ [TB.Builder] → Text+    intersperseText bs =+      toStrict (toLazyText (mconcat (intersperse (TB.singleton ';') bs)))+ interpretOnBuffer ∷ [Action] → Buffer ⊸ Buffer interpretOnBuffer xs z = foldlIntoBuffer go z xs   where     go ∷ Buffer ⊸ Action → Buffer-    go b (AppendText    x) = b |> x-    go b (PrependText   x) = x <| b-    go b (AppendChar    x) = b |>. x-    go b (PrependChar   x) = x .<| b-    go b (AppendHex     x) = b |>& x-    go b (PrependHex    x) = x &<| b-    go b (AppendDec     x) = b |>$ x-    go b (PrependDec    x) = x $<| b-    go b (AppendDec30   x) = b |>$ x-    go b (PrependDec30  x) = x $<| b-    go b (AppendDouble  x) = b |>% x-    go b (PrependDouble x) = x %<| b-    go b (AppendSpaces  n) = b |>… n-    go b (PrependSpaces n) = n …<| b+    go b (AppendText     x) = b |> x+    go b (PrependText    x) = x <| b+    go b (AppendChar     x) = b |>. x+    go b (PrependChar    x) = x .<| b+    go b (AppendChars   n x) = appendChars n x b+    go b (PrependChars  n x) = prependChars n x b+    go b (JustifyLeft   n x) = justifyLeft n x b+    go b (JustifyRight  n x) = justifyRight n x b+    go b (Center        n x) = center n x b+    go b (HexInt r s t u v w x) = s &<| ";"# #<| t &<| ";"# #<| x &<|+                                  (b |>& r |># ";"# |>& u |># ";"# |>& v |># ";"# |>& w)+    go b (HexWord u v w x) = u &<| ";"# #<| x &<| (b |>& v |># ";"# |>& w)+    go b (AppendHexI     x) = case x of {SomeIntN i → b |>& i}+    go b (PrependHexI    x) = case x of {SomeIntN i → i &<| b}+    go b (AppendHexW     x) = case x of {SomeWordN i → b |>& i}+    go b (PrependHexW    x) = case x of {SomeWordN i → i &<| b}+    go b (DecInt  r s t u v w x) = s $<| ";"# #<| t $<| ";"# #<| x $<| (b |>$ r |># ";"# |>$ u |># ";"# |>$ v |># ";"# |>$ w)+    go b (DecWord r s t u v w x) = s $<| ";"# #<| t $<| ";"# #<| x $<| (b |>$ r |># ";"# |>$ u |># ";"# |>$ v |># ";"# |>$ w)+    go b (AppendDecW     x) = b |>$ x+    go b (PrependDecW    x) = x $<| b+    go b (AppendDecI     x) = b |>$ x+    go b (PrependDecI    x) = x $<| b+    go b (AppendDecI30   x) = b |>$ x+    go b (PrependDecI30  x) = x $<| b+    go b (AppendDouble   x) = b |>% x+    go b (PrependDouble  x) = x %<| b+    go b (AppendSpaces   n) = b |>… n+    go b (PrependSpaces  n) = n …<| b  main ∷ IO () main = defaultMain $ testGroup "All"@@ -118,6 +228,8 @@   , testProperty "append addr#" prop3   , testProperty "prepend addr#" prop4   , testProperty "bytestring builder" prop5+  , testProperty "CSE 1" prop6+  , testProperty "CSE 2" prop7   ]  prop1 ∷ [Action] → Property@@ -144,53 +256,190 @@   where     addr# = "foo"#     f1, f2 :: Buffer ⊸ Buffer-    f1 = \b → addr# <|# interpretOnBuffer acts b+    f1 = \b → addr# #<| interpretOnBuffer acts b     f2 = \b → T.pack "foo" <| interpretOnBuffer acts b  prop5 ∷ [Action] → Property prop5 acts = T.encodeUtf8 (interpretOnText acts mempty) ===   runBufferBS (\b → interpretOnBuffer acts b) --------------------------------------------------------------------------------+prop6 :: Property+prop6 = T.pack "_a_b" ===+  runBuffer (\buf -> buf |>. '_' |>. 'a' |>+    runBuffer (\buf' -> buf' |>. '_' |>. 'b')) -newtype Int30 = Int30' Int-  deriving stock (Eq, Ord, Show)+prop7 :: Property+prop7 =+    let !x = runBuffer (\buf -> (buf |>. '_' |>. 'a') |>… 5)+        !y = runBuffer (\buf -> (buf |>. '_' |>. 'b') |>… 5)+    in (x, y) === (T.pack "_a     ", T.pack "_b     ")++--------------------------------------------------------------------------------+-- IntN+--------------------------------------------------------------------------------++newtype IntN (n ∷ Natural) = IntN' {unIntN ∷ Int64}+  deriving stock (Eq, Ord)   deriving newtype (Enum, Real, Integral) -pattern Int30 :: Int -> Int30-pattern Int30 x <- Int30' x where-  Int30 x = Int30' (x .&. ((1 `shiftL` 30) - 1))-{-# COMPLETE Int30 #-}+instance (KnownNat n) ⇒ Show (IntN n) where+  showsPrec p (IntN x) = showParen (p > 10)+    (\s → mconcat ["IntN @", show (natVal (Proxy @n)), " ", show x, s]) -instance Arbitrary Int30 where-  arbitrary = Int30 <$> arbitrary-  shrink (Int30 x) = Int30 <$> shrink x+pattern IntN ∷ forall n. (KnownNat n) => Int64 → IntN n+pattern IntN x ← IntN' x where+  IntN x = IntN' x'+    where+    -- If the nth bit is 1, then interpret the value as negative and fill the+    -- bits from nth position with 1s. Otherwise clear them to 0s.+    size = intSize (Proxy @n)+    x' = if testBit x (size - 1)+      then x .|. m1+      else x .&. m2+    m1 = complement ((1 `shiftL` (size - 1)) - 1)+    m2 = (1 `shiftL` size) - 1 -instance Bounded Int30 where-  minBound = negate (1 `shiftL` 30)-  maxBound = (1 `shiftL` 30) - 1+{-# COMPLETE IntN #-} -instance Num Int30 where-  Int30 x + Int30 y = Int30 (x + y)-  Int30 x * Int30 y = Int30 (x * y)-  abs (Int30 x) = Int30 (abs x)+intSize ∷ forall p n. (KnownNat n) => p n → Int+intSize _ = fromInteger (natVal (Proxy @n))++instance (KnownNat n) => Arbitrary (IntN n) where+  arbitrary =+    IntN <$> chooseBoundedIntegral (unIntN @n minBound, unIntN @n maxBound)+  shrink = shrinkIntegral++instance (KnownNat n) => Bounded (IntN n) where+  minBound = IntN (negate (1 `shiftL` (intSize (Proxy @n) - 1)))+  maxBound = IntN ((1 `shiftL` (intSize (Proxy @n) - 1)) - 1)++instance (KnownNat n) => Num (IntN n) where+  IntN x + IntN y = IntN (x + y)+  IntN x * IntN y = IntN (x * y)+  abs (IntN x) = IntN (abs x)   signum = undefined-  negate  (Int30 x) = Int30 (negate x)-  fromInteger x = Int30 (fromInteger x)+  negate (IntN x) = IntN (negate x)+  fromInteger x = IntN (fromInteger x) -instance Bits Int30 where-  (.&.) = undefined-  (.|.) = undefined+instance (KnownNat n) => Bits (IntN n) where+  IntN a .&. IntN b = IntN (a .&. b)+  IntN a .|. IntN b = IntN (a .|. b)   xor = undefined-  complement = undefined-  shift (Int30 x) i = Int30 (shift x i)+  complement (IntN x) = IntN (complement x)+  shift (IntN x) i = IntN (shift x i)   rotate = undefined-  bitSize = const 30-  bitSizeMaybe = const (Just 30)+  bitSize = const (intSize (Proxy @n))+  bitSizeMaybe = const (Just (intSize (Proxy @n)))   isSigned = const True-  testBit = undefined-  bit = undefined+  testBit (IntN x) = testBit x+  bit = bitDefault   popCount = undefined -instance FiniteBits Int30 where-  finiteBitSize = const 30+instance (KnownNat n) => FiniteBits (IntN n) where+  finiteBitSize = const (intSize (Proxy @n))++data SomeIntN = forall n. (KnownNat n) ⇒ SomeIntN (IntN n)++instance Eq SomeIntN where+  SomeIntN (IntN @n1 i1) == SomeIntN (IntN @n2 i2) =+    case sameNat (Proxy @n1) (Proxy @n2) of+      Just _  → i1 == i2+      Nothing → False++instance Ord SomeIntN where+  SomeIntN (IntN @n1 i1) `compare` SomeIntN (IntN @n2 i2) =+    case cmpNat (Proxy @n1) (Proxy @n2) of+      LTI → LT+      EQI → compare i1 i2+      GTI → GT++instance Show SomeIntN where+  show (SomeIntN i) = show i++instance Arbitrary SomeIntN where+  arbitrary = do+    s <- chooseInt (8, 64)+    case someNatVal (toInteger s) of+      Just (SomeNat (Proxy ∷ Proxy n)) →+        SomeIntN <$> arbitraryBoundedIntegral @(IntN n)+      Nothing → error "impossible"+  shrink (SomeIntN i) = SomeIntN <$> shrinkIntegral i++--------------------------------------------------------------------------------+-- WordN+--------------------------------------------------------------------------------++newtype WordN (n ∷ Natural) = WordN' { unWordN :: Word64 }+  deriving stock (Eq, Ord)+  deriving newtype (Enum, Real, Integral)++instance (KnownNat n) ⇒ Show (WordN n) where+  showsPrec p (WordN x) = showParen (p > 10)+    (\s → mconcat ["WordN @", show (natVal (Proxy @n)), " ", show x, s])++pattern WordN ∷ forall n. (KnownNat n) => Word64 → WordN n+pattern WordN x ← WordN' x where+  WordN x = WordN' (x .&. ((1 `shiftL` intSize (Proxy @n)) - 1))++{-# COMPLETE WordN #-}++instance (KnownNat n) => Arbitrary (WordN n) where+  arbitrary =+    WordN <$> chooseBoundedIntegral (unWordN @n minBound, unWordN @n maxBound)+  shrink = shrinkIntegral++instance (KnownNat n) => Bounded (WordN n) where+  minBound = WordN' 0+  maxBound = WordN ((1 `shiftL` intSize (Proxy @n)) - 1)++instance (KnownNat n) => Num (WordN n) where+  WordN x + WordN y = WordN (x + y)+  WordN x * WordN y = WordN (x * y)+  abs = id+  signum = undefined+  negate (WordN x) = WordN (negate x)+  fromInteger x = WordN (fromInteger x)++instance (KnownNat n) => Bits (WordN n) where+  WordN a .&. WordN b = WordN (a .&. b)+  WordN a .|. WordN b = WordN (a .|. b)+  xor = undefined+  complement (WordN x) = WordN (complement x)+  shift (WordN x) i = WordN (shift x i)+  rotate = undefined+  bitSize = const (intSize (Proxy @n))+  bitSizeMaybe = const (Just (intSize (Proxy @n)))+  isSigned = const False+  testBit (WordN x) = testBit x+  bit = bitDefault+  popCount = undefined++instance (KnownNat n) => FiniteBits (WordN n) where+  finiteBitSize = const (intSize (Proxy @n))++data SomeWordN = forall n. (KnownNat n) ⇒ SomeWordN (WordN n)++instance Eq SomeWordN where+  SomeWordN (WordN @n1 i1) == SomeWordN (WordN @n2 i2) =+    case sameNat (Proxy @n1) (Proxy @n2) of+      Just _  → i1 == i2+      Nothing → False++instance Ord SomeWordN where+  SomeWordN (WordN @n1 i1) `compare` SomeWordN (WordN @n2 i2) =+    case cmpNat (Proxy @n1) (Proxy @n2) of+      LTI → LT+      EQI → compare i1 i2+      GTI → GT++instance Show SomeWordN where+  show (SomeWordN i) = show i++instance Arbitrary SomeWordN where+  arbitrary = do+    s <- chooseInt (8, 64)+    case someNatVal (toInteger s) of+      Just (SomeNat (Proxy ∷ Proxy n)) →+        SomeWordN <$> arbitraryBoundedIntegral @(WordN n)+      Nothing → error "impossible"+  shrink (SomeWordN i) = SomeWordN <$> shrinkIntegral i
text-builder-linear.cabal view
@@ -1,12 +1,12 @@ cabal-version:   2.4 name:            text-builder-linear-version:         0.1.1.1+version:         0.1.2 license:         BSD-3-Clause license-file:    LICENSE copyright:       2022 Andrew Lelechenko maintainer:      Andrew Lelechenko <andrew.lelechenko@gmail.com> author:          Andrew Lelechenko-tested-with:     ghc ==9.2.8 ghc ==9.4.7 ghc ==9.6.2 ghc ==9.8.1+tested-with:     ghc ==9.2.8 ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1 homepage:        https://github.com/Bodigrim/linear-builder synopsis:        Builder for Text and ByteString based on linear types description:@@ -30,6 +30,7 @@      hs-source-dirs:     src     other-modules:+        Data.Text.Builder.Linear.Array         Data.Text.Builder.Linear.Char         Data.Text.Builder.Linear.Dec         Data.Text.Builder.Linear.Double@@ -63,7 +64,7 @@         base,         text,         text-builder-linear,-        tasty >=1.4 && <1.5,+        tasty >=1.4 && <1.6,         tasty-quickcheck >=0.10 && <0.11  benchmark linear-builder-bench@@ -85,5 +86,10 @@         bytestring,         text,         text-builder-linear,+        -- NOTE: The following packages are optional, but are not required that+        --       often. While they could be guarded by a flag, we prefer keeping+        --       the Hackage page simple. Just uncomment these lines when needed.+        -- bytestring-strict-builder >= 0.4.5 && < 0.5+        -- text-builder >= 0.6.7 && < 0.7,         tasty,         tasty-bench >=0.3.2 && <0.4