diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for `text-short` + +## 0.1 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Herbert Valerio Riedel + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/cbits.c b/cbits/cbits.c new file mode 100644 --- /dev/null +++ b/cbits/cbits.c @@ -0,0 +1,141 @@ +/* + * Copyright (c) 2017, Herbert Valerio Riedel + * + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following + * disclaimer in the documentation and/or other materials provided + * with the distribution. + * + * * Neither the name of Herbert Valerio Riedel nor the names of other + * contributors may be used to endorse or promote products derived + * from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include +#include +#include + +/* Count number of code-points in well-formed utf8 string */ +size_t +hs_text_short_length(const uint8_t buf[], const size_t n) +{ + size_t j,l = 0; + for (j = 0; j < n; j++) + if ((buf[j] & 0xc0) != 0x80) + l++; + + return l; +} + +/* Validate UTF8 encoding + + 7 bits | 0xxxxxxx +11 bits | 110yyyyx 10xxxxxx +16 bits | 1110yyyy 10yxxxxx 10xxxxxx +21 bits | 11110yyy 10yyxxxx 10xxxxxx 10xxxxxx + +Valid code-points: + + [U+0000 .. U+D7FF] + [U+E000 .. U+10FFFF] + +Return values: + + 0 -> ok + 1 -> invalid byte/code-point + 2 -> truncated + +*/ + +int +hs_text_short_is_valid_utf8(const uint8_t buf[], const size_t n) +{ + size_t j = 0; + + while (j < n) { + const uint8_t b0 = buf[j++]; + + if (!(b0 & 0x80)) + continue; + + if ((b0 & 0xe0) == 0xc0) { + if (!(b0 & 0x1e)) return 1; /* denorm */ + if (j >= n) return 2; + + /* b1 */ + if ((buf[j++] & 0xc0) != 0x80) return 1; + continue; + } + + if ((b0 & 0xf0) == 0xe0) { + if ((j+1) >= n) return 2; + + const uint8_t b1 = buf[j++]; + if ((b1 & 0xc0) != 0x80) return 1; + if (!((b0 & 0x0f) | (b1 & 0x20))) return 1; /* denorm */ + /* UTF16 Surrogate pairs [U+D800 .. U+DFFF] */ + if ((b0 == 0xed) && (b1 & 0x20)) return 1; + + /* b2 */ + if ((buf[j++] & 0xc0) != 0x80) return 1; + + continue; + } + + if ((b0 & 0xf8) == 0xf0) { + if ((j+2) >= n) return 2; + + const uint8_t b1 = buf[j++]; + if ((b1 & 0xc0) != 0x80) return 1; + if (!((b0 & 0x07) | (b1 & 0x30))) return 1; /* denorm */ + /* make sure we're below U+10FFFF */ + if (b0 > 0xf4) return 1; + if ((b0 == 0xf4) && (b1 & 0x30)) return 1; + + /* b2 */ + if ((buf[j++] & 0xc0) != 0x80) return 1; + /* b3 */ + if ((buf[j++] & 0xc0) != 0x80) return 1; + + continue; + } + + return 1; + } + + assert(j == n); + + return 0; +} + + +/* Test whether well-formed UTF8 string contains only ASCII code-points + * Returns length of longest ASCII-code-point prefix. + */ +size_t +hs_text_short_is_ascii(const uint8_t buf[], const size_t n) +{ + size_t j; + for (j = 0; j < n; j++) + if (buf[j] & 0x80) + return j; +} diff --git a/src-test/Tests.hs b/src-test/Tests.hs new file mode 100644 --- /dev/null +++ b/src-test/Tests.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main(main) where + +import qualified Data.Text.Short as IUT +import Test.Tasty +import Test.Tasty.QuickCheck as QC +import Test.Tasty.HUnit +import Test.QuickCheck.Instances () +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.String as D.S +import Data.Binary +import Data.Char +import Data.Monoid + +fromByteStringRef = either (const Nothing) (Just . IUT.fromText) . T.decodeUtf8' + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [unitTests,qcProps] + +qcProps :: TestTree +qcProps = testGroup "Properties" + [ QC.testProperty "length/fromText" $ \t -> IUT.length (IUT.fromText t) == T.length t + , QC.testProperty "length/fromString" $ \s -> IUT.length (IUT.fromString s) == length s + , QC.testProperty "toText.fromText" $ \t -> (IUT.toText . IUT.fromText) t == t + , QC.testProperty "fromByteString" $ \b -> IUT.fromByteString b == fromByteStringRef b + , QC.testProperty "fromByteString.toByteString" $ \t -> let ts = IUT.fromText t in (IUT.fromByteString . IUT.toByteString) ts == Just ts + , QC.testProperty "toString.fromString" $ \s -> (IUT.toString . IUT.fromString) s == s + , QC.testProperty "isAscii" $ \s -> IUT.isAscii (IUT.fromString s) == all isAscii s + , QC.testProperty "isAscii2" $ \t -> IUT.isAscii (IUT.fromText t) == T.all isAscii t + ] + +unitTests = testGroup "Unit-tests" + [ testCase "fromText mempty" $ IUT.fromText mempty @?= mempty + , testCase "fromShortByteString [0xc0,0x80]" $ IUT.fromShortByteString "\xc0\x80" @?= Nothing + , testCase "fromByteString [0xc0,0x80]" $ IUT.fromByteString "\xc0\x80" @?= Nothing + , testCase "IsString U+D800" $ "\xFFFD" @?= (IUT.fromString "\xD800") +-- , testCase "IsString U+D800" $ (IUT.fromString "\xD800") @?= IUT.fromText ("\xD800" :: T.Text) + + , testCase "Binary.encode" $ encode ("Hello \8364 & \171581!\NUL" :: IUT.ShortText) @?= "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\DC2Hello \226\130\172 & \240\169\184\189!\NUL" + , testCase "Binary.decode" $ decode ("\NUL\NUL\NUL\NUL\NUL\NUL\NUL\DC2Hello \226\130\172 & \240\169\184\189!\NUL") @?= ("Hello \8364 & \171581!\NUL" :: IUT.ShortText) + ] diff --git a/src/Data/Text/Short.hs b/src/Data/Text/Short.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Short.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, MagicHash, UnliftedFFITypes, Trustworthy #-} + +-- | +-- Module : Data.Text.Short +-- Copyright : © Herbert Valerio Riedel 2017 +-- License : BSD3 +-- +-- Maintainer : hvr@gnu.org +-- Stability : stable +-- +-- Memory-efficient representation of Unicode text strings. +module Data.Text.Short + ( -- * The 'ShortText' type + ShortText + + -- * Basic operations + , Data.Text.Short.null + , Data.Text.Short.length + , Data.Text.Short.isAscii + + -- * Conversions + -- ** 'String' + , Data.Text.Short.fromString + , toString + + -- ** 'T.Text' + , fromText + , toText + + -- ** 'BS.ByteString' + , fromShortByteString + , toShortByteString + + , fromByteString + , toByteString + + , toBuilder + + ) where + +import Control.DeepSeq (NFData) +-- import Control.Exception as E +import qualified Data.ByteString as BS +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Short.Internal as BSSI +import Data.Char +import Data.Hashable (Hashable) +import Data.Semigroup +import qualified Data.String as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Foreign.C +import GHC.Exts (ByteArray#) +import qualified GHC.Foreign as GHC +import GHC.IO.Encoding +import System.IO.Unsafe +import Data.Binary +import qualified Data.ByteString.Builder as BB + +-- | A compact representation of Unicode strings. +-- +-- This type relates to 'T.Text' as 'ShortByteString' relates to 'BS.ByteString' by providing a more compact type. Please consult the documentation of "Data.ByteString.Short" for more information. +-- +-- Currently, a boxed unshared 'T.Text' has a memory footprint of 6 words (i.e. 48 bytes on 64-bit systems) plus 2 or 4 bytes per code-point (due to the internal UTF-16 representation). Each 'T.Text' value which can share its payload with another 'T.Text' requires only 4 words additionally. Unlike 'BS.ByteString', 'T.Text' use unpinned memory. +-- +-- In comparison, the footprint of a boxed 'ShortText' is only 4 words (i.e. 32 bytes on 64-bit systems) plus 1/2/3/4 bytes per code-point (due to the internal UTF-8 representation). +-- It can be shown that for realistic data . +-- +newtype ShortText = ShortText ShortByteString + deriving (Eq,Ord,Monoid,Semigroup,Hashable,NFData) + +instance Show ShortText where + showsPrec p (ShortText b) = showsPrec p (decodeStringShort' utf8 b) + show (ShortText b) = show (decodeStringShort' utf8 b) + +instance Read ShortText where + readsPrec p = map (\(x,s) -> (ShortText $ encodeStringShort utf8 x,s)) . readsPrec p + +-- | Behaviour for @[U+D800 .. U+DFFF]@ matches the 'IsString' instance for 'T.Text' +instance S.IsString ShortText where + fromString = fromString + +-- | The 'Binary' encoding matches the one for 'T.Text' +#if MIN_VERSION_binary(0,8,1) +instance Binary ShortText where + put = put . toShortByteString + get = do + sbs <- get + case fromShortByteString sbs of + Nothing -> fail "Binary.get(ShortText): Invalid UTF-8 stream" + Just st -> return st +#else +-- fallback via 'ByteString' instance +instance Binary ShortText where + put = put . toByteString + get = do + bs <- get + case fromByteString bs of + Nothing -> fail "Binary.get(ShortText): Invalid UTF-8 stream" + Just st -> return st +#endif + +-- | /O(1)/ Test whether a 'ShortText' is empty. +null :: ShortText -> Bool +null = BSS.null . toShortByteString + +-- | /O(n)/ Count the number of Unicode code-points in a 'ShortText'. +length :: ShortText -> Int +length st = fromIntegral $ unsafePerformIO (c_text_short_length (toByteArray# st) (toCSize st)) + +foreign import ccall unsafe "hs_text_short_length" c_text_short_length :: ByteArray# -> CSize -> IO CSize + +-- | /O(n)/ Test whether 'ShortText' contains only ASCII code-points (i.e. only U+0000 through U+007F). +isAscii :: ShortText -> Bool +isAscii st = (== sz) $ unsafePerformIO (c_text_short_is_ascii (toByteArray# st) sz) + where + sz = toCSize st + +foreign import ccall unsafe "hs_text_short_is_ascii" c_text_short_is_ascii :: ByteArray# -> CSize -> IO CSize + +---------------------------------------------------------------------------- + +toCSize :: ShortText -> CSize +toCSize = fromIntegral . BSS.length . toShortByteString + +toByteArray# :: ShortText -> ByteArray# +toByteArray# (ShortText (BSSI.SBS ba#)) = ba# + +-- | /O(0)/ Converts to UTF-8 encoded 'ShortByteString' +-- +-- This operation has effectively no overhead, as it's currently merely a @newtype@-cast. +toShortByteString :: ShortText -> ShortByteString +toShortByteString (ShortText b) = b + +-- | /O(n)/ Converts to UTF-8 encoded 'BS.ByteString' +toByteString :: ShortText -> BS.ByteString +toByteString = BSS.fromShort . toShortByteString + +-- | Construct a 'BB.Builder' that encodes 'ShortText' as UTF-8. +toBuilder :: ShortText -> BB.Builder +toBuilder = BB.shortByteString . toShortByteString + +-- | /O(n)/ Convert to 'String' +toString :: ShortText -> String +toString = decodeStringShort' utf8 . toShortByteString + +-- | /O(n)/ Convert to 'T.Text' +-- +-- This is currently not /O(1)/ because currently 'T.Text' uses UTF-16 as its internal representation. +-- In the event that 'T.Text' will change its internal representation to UTF-8 this operation will become /O(1)/. +toText :: ShortText -> T.Text +toText = T.decodeUtf8 . toByteString + +---- + +-- | /O(n)/ Construct/pack from 'String' +-- +-- Note: This function is total because it replaces the (invalid) code-points U+D800 through U+DFFF with the replacement character U+FFFD. +fromString :: String -> ShortText +fromString = ShortText . encodeStringShort utf8 . map r + where + r c | 0xd800 <= x && x < 0xe000 = '\xFFFD' + | otherwise = c + where + x = ord c + +-- | /O(n)/ Construct 'ShortText' from 'T.Text' +-- +-- This is currently not /O(1)/ because currently 'T.Text' uses UTF-16 as its internal representation. +-- In the event that 'T.Text' will change its internal representation to UTF-8 this operation will become /O(1)/. +fromText :: T.Text -> ShortText +fromText = fromByteString' . T.encodeUtf8 + +-- | /O(n)/ Construct 'ShortText' from UTF-8 encoded 'ShortByteString' +-- +-- This operation doesn't copy the input 'ShortByteString' but it +-- cannot be /O(1)/ because we need to validate the UTF-8 encoding. +-- +-- Returns 'Nothing' in case of invalid UTF-8 encoding. +fromShortByteString :: ShortByteString -> Maybe ShortText +fromShortByteString sbs + | isValidUtf8 st = Just st + | otherwise = Nothing + where + st = ShortText sbs + +-- | /O(n)/ Construct 'ShortText' from UTF-8 encoded 'BS.ByteString' +-- +-- Returns 'Nothing' in case of invalid UTF-8 encoding. +fromByteString :: BS.ByteString -> Maybe ShortText +fromByteString = fromShortByteString . BSS.toShort + +---------------------------------------------------------------------------- + +-- non-validating +fromByteString' :: BS.ByteString -> ShortText +fromByteString' = ShortText . BSS.toShort + + + +---------------------------------------------------------------------------- + +encodeString :: TextEncoding -> String -> BS.ByteString +encodeString te str = unsafePerformIO $ GHC.withCStringLen te str BS.packCStringLen + +-- decodeString :: TextEncoding -> BS.ByteString -> Maybe String +-- decodeString te bs = cvtEx $ unsafePerformIO $ try $ BS.useAsCStringLen bs (GHC.peekCStringLen te) +-- where +-- cvtEx :: Either IOException a -> Maybe a +-- cvtEx = either (const Nothing) Just + +decodeString' :: TextEncoding -> BS.ByteString -> String +decodeString' te bs = unsafePerformIO $ BS.useAsCStringLen bs (GHC.peekCStringLen te) + +decodeStringShort' :: TextEncoding -> ShortByteString -> String +decodeStringShort' te = decodeString' te . BSS.fromShort + +encodeStringShort :: TextEncoding -> String -> BSS.ShortByteString +encodeStringShort te = BSS.toShort . encodeString te + + +isValidUtf8 :: ShortText -> Bool +isValidUtf8 st = (==0) $ unsafePerformIO (c_text_short_is_valid_utf8 (toByteArray# st) (toCSize st)) + +foreign import ccall unsafe "hs_text_short_is_valid_utf8" c_text_short_is_valid_utf8 :: ByteArray# -> CSize -> IO CInt + +{- TODO: +{-# RULES "ShortText strlit" forall s . fromString (unpackCString# s) = fromAddr# #-} +... +-} diff --git a/text-short.cabal b/text-short.cabal new file mode 100644 --- /dev/null +++ b/text-short.cabal @@ -0,0 +1,61 @@ +name: text-short +version: 0.1 +synopsis: Memory-efficient representation of Unicode text strings +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +bug-reports: https://github.com/hvr/text-short/issues +category: Data +build-type: Simple +cabal-version: >=1.10 +description: This package provides the 'ShortText' type which is suitable for keeping many short strings in memory. This is similiar to how 'ShortByteString' relates to 'ByteString'. + . + The main difference between 'Text' and 'ShortText' is that 'ShortText' uses UTF-8 instead of UTF-16 internally and also doesn't support slicing (thereby saving 2 words). Consequently, the memory footprint of a (boxed) 'ShortText' value is 4 words (2 words when unboxed) plus the length of the UTF-8 encoded payload. + +extra-source-files: ChangeLog.md + +Source-Repository head + Type: git + Location: https://github.com/hvr/text-short.git + +library + default-language: Haskell2010 + exposed-modules: Data.Text.Short + build-depends: base >= 4.7 && < 4.11 + , bytestring >= 0.10.4 && < 0.11 + , hashable >= 1.2.6 && < 1.3 + , deepseq >= 1.3 && < 1.5 + , text >= 1.0 && < 1.3 + , binary >= 0.7.1 && < 0.9 + + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.2 && < 0.19 + + hs-source-dirs: src + + default-language: Haskell2010 + other-extensions: CPP + , GeneralizedNewtypeDeriving + , MagicHash + , UnliftedFFITypes + , Trustworthy + + c-sources: cbits/cbits.c + ghc-options: -Wall + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: src-test + main-is: Tests.hs + + build-depends: base + , binary + , text + , text-short + -- deps which don't inherit constraints from library stanza: + , tasty >= 0.11.2 && < 0.12 + , tasty-quickcheck >= 0.8.4 && < 0.9 + , tasty-hunit >= 0.9.2 && < 0.10 + , quickcheck-instances >= 0.3.14 && < 0.4