diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for Z-Data +## 0.6.0.0 -- 2020-02-04 + +* Add `primArrayFromBE/primArrayFromBE` to `Z.Data.Array.Unaligned`. +* Change `[Char]` 's JSON instance to use JSON text, Add `Bytes` 's JSON instance to use base64 encoding. +* Add `escapeCBytes`, `toEscapedText` to `Z.Data.CBytes`, change `CBytes` 's JSON instance to use base64 encoding. + ## 0.5.0.0 -- 2020-01-15 * Add `ParseChunks` type alias, remove `parseChunks'` from `Z.Data.JSON`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ Z-Data LICENSE -Copyright (c) Project Z Contributors, 2017-2020 +Copyright (c) Z.Haskell Contributors, 2017-2020 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ ## Z-Data -[![Hackage](https://img.shields.io/hackage/v/Z-Data.svg?style=flat)](https://hackage.haskell.org/package/Z-Data) [![Linux Build Status](https://github.com/haskell-Z/z-data/workflows/ubuntu-ci/badge.svg)](https://github.com/haskell-Z/z-data/actions) [![MacOS Build Status](https://github.com/haskell-Z/z-data/workflows/osx-ci/badge.svg)](https://github.com/haskell-Z/z-data/actions) [![Windows Build Status](https://github.com/haskell-Z/z-data/workflows/win-ci/badge.svg)](https://github.com/haskell-Z/z-data/actions) +[![Hackage](//img.shields.io/hackage/v/Z-Data.svg?style=flat)](//hackage.haskell.org/package/Z-Data) [![Linux Build Status](//github.com/Z.Haskell/z-data/workflows/ubuntu-ci/badge.svg)](//github.com/Z.Haskell/z-data/actions) [![MacOS Build Status](//github.com/Z.Haskell/z-data/workflows/osx-ci/badge.svg)](//github.com/Z.Haskell/z-data/actions) [![Windows Build Status](//github.com/Z.Haskell/z-data/workflows/win-ci/badge.svg)](//github.com/Z.Haskell/z-data/actions) -This package is part of [Z](https://github.com/haskell-Z/Z) project, provides basic data structures and functions: +This package is part of [Z.Haskell](//zhaskell.github.io/docs/) project, providing basic data structures and functions: * Array, vector(array slice), sorting, searching * Text based UTF-8, basic unicode manipulating, regex @@ -14,7 +14,7 @@ * A working haskell compiler system, GHC(>=8.6), cabal-install(>=2.4), hsc2hs. -* Tests need [hspec-discover](https://hackage.haskell.org/package/hspec-discover). +* Tests need [hspec-discover](//hackage.haskell.org/package/hspec-discover). ## Example usage @@ -77,7 +77,7 @@ ```bash # get code -git clone --recursive git@github.com:haskell-Z/z-data.git +git clone --recursive git@github.com:Z.Haskell/z-data.git cd z-data # build cabal build diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,13 +1,13 @@ cabal-version: 2.4 name: Z-Data -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause license-file: LICENSE -author: Project Z Contributors +author: Z.Haskell Contributors maintainer: winterland1989@gmail.com -copyright: (c) Project Z Contributors +copyright: (c) Z.Haskell Contributors category: Data build-type: Custom homepage: https://github.com/haskell-Z/z-data diff --git a/Z/Data/ASCII.hs b/Z/Data/ASCII.hs --- a/Z/Data/ASCII.hs +++ b/Z/Data/ASCII.hs @@ -1,3 +1,16 @@ +{-| +Module : Z.Data.ASCII +Description : ASCII chars +Copyright : (c) Dong Han, 2020 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +ASCII Chars utility. + +-} + module Z.Data.ASCII where import GHC.Word diff --git a/Z/Data/Array/Unaligned.hs b/Z/Data/Array/Unaligned.hs --- a/Z/Data/Array/Unaligned.hs +++ b/Z/Data/Array/Unaligned.hs @@ -17,6 +17,7 @@ import Control.Monad.Primitive import Data.Primitive.ByteArray import Data.Primitive.PrimArray +import Data.Primitive.Types import GHC.Int import GHC.IO import GHC.Exts @@ -125,6 +126,36 @@ {-# INLINE indexPrimWord8ArrayAs #-} indexPrimWord8ArrayAs (PrimArray ba#) (I# i#) = indexWord8ArrayAs# ba# i# +-- | Encode PrimArray elements in big endian. +primArrayToBE :: forall a. (Prim a, Unaligned (BE a)) => PrimArray a -> Int -> Int -> PrimArray Word8 +{-# INLINE primArrayToBE #-} +primArrayToBE parr off len = unsafeDupablePerformIO $ do + buf <- newPrimArray siz + go buf off 0 + where + s = getUnalignedSize (unalignedSize @(BE a)) + siz = len * s + go buf !i !j + | j == siz = unsafeFreezePrimArray buf + | otherwise = do + writePrimWord8ArrayAs buf j (BE (indexPrimArray parr i)) + go buf (i+1) (j+s) + +-- | Decode PrimArray elements in big endian. +primArrayFromBE :: forall a. (Prim a, Unaligned (BE a)) => PrimArray Word8 -> Int -> Int -> PrimArray a +{-# INLINE primArrayFromBE #-} +primArrayFromBE parr off len = unsafeDupablePerformIO $ do + buf <- newPrimArray siz + go buf off 0 + where + s = getUnalignedSize (unalignedSize @(BE a)) + siz = len `quot` s + go buf !i !j + | j == siz = unsafeFreezePrimArray buf + | otherwise = do + writePrimArray buf j (getBE (indexPrimWord8ArrayAs parr i)) + go buf (i+s) (j+1) + instance Unaligned Word8 where {-# INLINE unalignedSize #-} unalignedSize = UnalignedSize 1 @@ -154,6 +185,7 @@ -- | big endianess wrapper -- newtype BE a = BE { getBE :: a } deriving (Show, Eq) + #define USE_HOST_IMPL(END) \ {-# INLINE writeWord8ArrayAs# #-}; \ diff --git a/Z/Data/Builder.hs b/Z/Data/Builder.hs --- a/Z/Data/Builder.hs +++ b/Z/Data/Builder.hs @@ -30,6 +30,7 @@ , writeN -- * Pritimive builders , encodePrim + , BE(..), LE(..) , encodePrimLE , encodePrimBE -- * More builders diff --git a/Z/Data/Builder/Base.hs b/Z/Data/Builder/Base.hs --- a/Z/Data/Builder/Base.hs +++ b/Z/Data/Builder/Base.hs @@ -42,6 +42,7 @@ , writeN -- * Pritimive builders , encodePrim + , BE(..), LE(..) , encodePrimLE , encodePrimBE -- * More builders @@ -103,7 +104,7 @@ -- Notes on 'IsString' instance: @Builder ()@'s 'IsString' instance use 'stringModifiedUTF8', -- which is different from 'stringUTF8' in that it DOES NOT PROVIDE UTF8 GUARANTEES! : -- --- * @\\NUL@ will be written as @\xC0 \x80@. +-- * @\\NUL@ will be written as @\\xC0 \\x80@. -- * @\\xD800@ ~ @\\xDFFF@ will be encoded in three bytes as normal UTF-8 codepoints. -- newtype Builder a = Builder { runBuilder :: (a -> BuildStep) -> BuildStep } @@ -317,6 +318,11 @@ f buf' offset' >> k () (Buffer buf' (offset'+n))))) -- | Write a primitive type in host byte order. +-- +-- @ +-- > encodePrim (256 :: Word16, BE 256 :: BE Word16) +-- > [0,1,1,0] +-- @ encodePrim :: forall a. Unaligned a => a -> Builder () {-# INLINE encodePrim #-} {-# SPECIALIZE INLINE encodePrim :: Word -> Builder () #-} diff --git a/Z/Data/Builder/Numeric.hs b/Z/Data/Builder/Numeric.hs --- a/Z/Data/Builder/Numeric.hs +++ b/Z/Data/Builder/Numeric.hs @@ -100,13 +100,12 @@ -- -- @ -- import Z.Data.Builder as B --- import Z.Data.Text as T -- --- > T.validate . B.buildBytes $ B.intWith defaultIFormat (12345 :: Int) +-- > B.buildText $ B.intWith defaultIFormat (12345 :: Int) -- "12345" --- > T.validate . B.buildBytes $ B.intWith defaultIFormat{width=10, padding=RightSpacePadding} (12345 :: Int) +-- > B.buildText $ B.intWith defaultIFormat{width=10, padding=RightSpacePadding} (12345 :: Int) -- "12345 " --- > T.validate . B.buildBytes $ B.intWith defaultIFormat{width=10, padding=ZeroPadding} (12345 :: Int) +-- > B.buildText $ B.intWith defaultIFormat{width=10, padding=ZeroPadding} (12345 :: Int) -- "0000012345" -- @ -- @@ -704,7 +703,8 @@ insertDot n [] = encodePrim DIGIT_0 >> insertDot (n-1) [] insertDot n (r:rs) = encodeDigit r >> insertDot (n-1) rs - ------------------------------------------------------------------------------ +------------------------------------------------------------------------------ + -- Conversion of 'Float's and 'Double's to ASCII in decimal using Grisu3 ------------------------------------------------------------------------ diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -31,6 +31,7 @@ import Control.DeepSeq import Control.Monad +import Control.Applicative ((<|>)) import Control.Exception import Control.Monad.Primitive import Control.Monad.ST @@ -62,7 +63,7 @@ import qualified Z.Data.Text.Print as T import qualified Z.Data.Text.UTF8Codec as T import qualified Z.Data.JSON.Base as JSON -import Z.Data.JSON.Base (()) +import Z.Data.JSON.Base ((.=), (.!), (.:)) import Z.Data.Text.UTF8Codec (encodeCharModifiedUTF8, decodeChar) import qualified Z.Data.Vector.Base as V import Z.Foreign hiding (fromStdString) @@ -106,12 +107,15 @@ let l = case V.elemIndex 0 arr of Just i -> i _ -> sizeofPrimArray arr - mpa <- newPrimArray (l+1) - copyPrimArray mpa 0 arr 0 l - -- write \\NUL terminator - writePrimArray mpa l 0 - pa <- unsafeFreezePrimArray mpa - return (CBytes pa)) + if l+1 == sizeofPrimArray arr + then return (CBytes arr) + else do + mpa <- newPrimArray (l+1) + copyPrimArray mpa 0 arr 0 l + -- write \\NUL terminator + writePrimArray mpa l 0 + pa <- unsafeFreezePrimArray mpa + return (CBytes pa)) -- | Use this pattern to match or construct 'CBytes', result will be trimmed down to first @\\NUL@ byte if there's any. pattern CB :: V.Bytes -> CBytes @@ -203,34 +207,27 @@ {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP _ = T.stringUTF8 . show . unpack --- | JSON instances check if 'CBytes' is proper UTF8 encoded, --- if it is, decode/encode it as 'T.Text', otherwise as 'V.Bytes'. +-- | JSON instances check if 'CBytes' is properly UTF8 encoded, +-- if it is, decode/encode it as 'T.Text', otherwise as an object with a base64 field. -- -- @ -- > encodeText ("hello" :: CBytes) -- "\"hello\"" --- > encodeText ("hello\\NUL" :: CBytes) -- @\\NUL@ is encoded as C0 80 --- "[104,101,108,108,111,192,128]" +-- > encodeText ("hello\\NUL" :: CBytes) -- @\\NUL@ is encoded as C0 80, which is illegal UTF8 +-- "{\"base64\":\"aGVsbG/AgA==\"}" -- @ instance JSON.JSON CBytes where {-# INLINE fromValue #-} - fromValue value = - case value of - JSON.String t -> - return (fromText t) - JSON.Array arr -> - fromBytes <$> V.traverseWithIndex - (\ k v -> JSON.fromValue v JSON.Index k) arr - _ -> JSON.fail' - "converting Z.Data.CBytes.CBytes failed, expected array or string" + fromValue v = JSON.withText "Z.Data.CBytes" (pure . fromText) v + <|> JSON.withFlatMapR "Z.Data.CBytes" (\ o -> fromBytes <$> o .: "base64") v {-# INLINE toValue #-} toValue cbytes = case toTextMaybe cbytes of Just t -> JSON.toValue t - Nothing -> JSON.toValue (toBytes cbytes) + Nothing -> JSON.object $ [ "base64" .= toBytes cbytes ] {-# INLINE encodeJSON #-} encodeJSON cbytes = case toTextMaybe cbytes of Just t -> JSON.encodeJSON t - Nothing -> B.square . JSON.commaSepVec . toBytes $ cbytes + Nothing -> JSON.object' $ "base64" .! toBytes cbytes -- | Concatenate two 'CBytes'. append :: CBytes -> CBytes -> CBytes diff --git a/Z/Data/JSON.hs b/Z/Data/JSON.hs --- a/Z/Data/JSON.hs +++ b/Z/Data/JSON.hs @@ -30,7 +30,7 @@ , decode, decode', decodeText, decodeText', ParseChunks, decodeChunks , encode, encodeChunks, encodeText -- * parse into JSON Value - , parseValue, parseValue', parseValueChunks, parseValueChunks' + , parseValue, parseValue', parseValueChunks -- * Generic functions , gToValue, gFromValue, gEncodeJSON -- * Convert 'Value' to Haskell data @@ -101,8 +101,9 @@ -- different behaviour, namely: -- -- * @Maybe a@ are encoded as JSON @null@ in 'Nothing' case, or directly encoded to its payload in 'Just' case. --- * @[a]@ are encoded to JSON array, including @[Char]@, i.e. there's no special treatment to 'String'. To get JSON string, use 'T.Text'. +-- * @[a]@ are encoded to JSON array, @[Char]@ are encoded into JSON string. -- * 'NonEmpty', 'Vector', 'PrimVector', 'HashSet', 'FlatSet', 'FlatIntSet' are also encoded to JSON array. +-- * 'Bytes' are encoded into JSON text using base64 encoding. -- * 'HashMap', 'FlatMap', 'FlatIntMap' are encoded to JSON object. -- $custom-settings diff --git a/Z/Data/JSON/Base.hs b/Z/Data/JSON/Base.hs --- a/Z/Data/JSON/Base.hs +++ b/Z/Data/JSON/Base.hs @@ -20,7 +20,7 @@ , decode, decode', decodeText, decodeText', P.ParseChunks, decodeChunks , encode, encodeChunks, encodeText -- * parse into JSON Value - , JV.parseValue, JV.parseValue', JV.parseValueChunks, JV.parseValueChunks' + , JV.parseValue, JV.parseValue', JV.parseValueChunks -- * Generic functions , gToValue, gFromValue, gEncodeJSON -- * Convert 'Value' to Haskell data @@ -97,6 +97,7 @@ import qualified Z.Data.Text as T import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Base64 as Base64 import qualified Z.Data.Vector.Extra as V import qualified Z.Data.Vector.FlatIntMap as FIM import qualified Z.Data.Vector.FlatIntSet as FIS @@ -1027,6 +1028,17 @@ {-# INLINE encodeJSON #-} encodeJSON = B.square . commaSepVec +-- | This is an INCOHERENT instance, encode binary data with base64 encoding. +instance {-# INCOHERENT #-} JSON V.Bytes where + fromValue = withText "Z.Data.Vector.Bytes" $ \ t -> + case Base64.base64Decode (T.getUTF8Bytes t) of + Just bs -> pure bs + Nothing -> fail' "illegal base64 encoding bytes" + {-# INLINE toValue #-} + toValue = String . Base64.base64EncodeText + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . Base64.base64EncodeBuilder + instance (Eq a, Hashable a, JSON a) => JSON (HS.HashSet a) where {-# INLINE fromValue #-} fromValue = withArray "Z.Data.Vector.FlatSet.FlatSet" $ \ vs -> @@ -1045,6 +1057,15 @@ toValue = Array . V.pack . map toValue {-# INLINE encodeJSON #-} encodeJSON = B.square . commaSepList + +-- | This is an INCOHERENT instance, to provide JSON text encoding behaviour. +instance {-# INCOHERENT #-} JSON [Char] where + {-# INLINE fromValue #-} + fromValue = withText "String" (pure . T.unpack) + {-# INLINE toValue #-} + toValue = String . T.pack + {-# INLINE encodeJSON #-} + encodeJSON = JB.string . T.pack instance JSON a => JSON (NonEmpty a) where {-# INLINE fromValue #-} diff --git a/Z/Data/JSON/Value.hs b/Z/Data/JSON/Value.hs --- a/Z/Data/JSON/Value.hs +++ b/Z/Data/JSON/Value.hs @@ -28,7 +28,6 @@ , parseValue , parseValue' , parseValueChunks - , parseValueChunks' -- * Value Parsers , value , object @@ -140,15 +139,9 @@ parseValue' = P.parse' (value <* skipSpaces <* P.endOfInput) -- | Increamental parse 'Value' without consuming trailing bytes. -parseValueChunks :: Monad m => m V.Bytes -> V.Bytes -> m (V.Bytes, Either P.ParseError Value) +parseValueChunks :: Monad m => P.ParseChunks m V.Bytes P.ParseError Value {-# INLINE parseValueChunks #-} parseValueChunks = P.parseChunks value - --- | Increamental parse 'Value' and consume all trailing JSON white spaces, if there're --- bytes left, parsing will fail. -parseValueChunks' :: Monad m => m V.Bytes -> V.Bytes -> m (Either P.ParseError Value) -{-# INLINE parseValueChunks' #-} -parseValueChunks' mi inp = snd <$> P.parseChunks (value <* skipSpaces <* P.endOfInput) mi inp -------------------------------------------------------------------------------- diff --git a/Z/Data/Parser.hs b/Z/Data/Parser.hs --- a/Z/Data/Parser.hs +++ b/Z/Data/Parser.hs @@ -35,7 +35,8 @@ -- * Basic parsers , ensureN, endOfInput, atEnd -- * Primitive decoders - , decodePrim, decodePrimLE, decodePrimBE + , decodePrim, BE(..), LE(..) + , decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces diff --git a/Z/Data/Parser/Base.hs b/Z/Data/Parser/Base.hs --- a/Z/Data/Parser/Base.hs +++ b/Z/Data/Parser/Base.hs @@ -24,7 +24,8 @@ -- * Basic parsers , ensureN, endOfInput, atEnd -- * Primitive decoders - , decodePrim, decodePrimLE, decodePrimBE + , decodePrim, BE(..), LE(..) + , decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces @@ -275,6 +276,7 @@ then Partial (\ inp' -> k (V.null inp') inp') else k False inp +-- | Decode a primitive type in host byte order. decodePrim :: forall a. (Unaligned a) => Parser a {-# INLINE decodePrim #-} {-# SPECIALIZE INLINE decodePrim :: Parser Word #-} @@ -297,6 +299,7 @@ where n = getUnalignedSize (unalignedSize @a) +-- | Decode a primitive type in little endian. decodePrimLE :: forall a. (Unaligned (LE a)) => Parser a {-# INLINE decodePrimLE #-} {-# SPECIALIZE INLINE decodePrimLE :: Parser Word #-} @@ -317,6 +320,7 @@ where n = getUnalignedSize (unalignedSize @(LE a)) +-- | Decode a primitive type in big endian. decodePrimBE :: forall a. (Unaligned (BE a)) => Parser a {-# INLINE decodePrimBE #-} {-# SPECIALIZE INLINE decodePrimBE :: Parser Word #-} diff --git a/Z/Data/Vector/Base64.hs b/Z/Data/Vector/Base64.hs --- a/Z/Data/Vector/Base64.hs +++ b/Z/Data/Vector/Base64.hs @@ -12,10 +12,8 @@ -} module Z.Data.Vector.Base64 - ( -- * The Base64Bytes type - Base64Bytes(..) - -- * Encoding & Decoding functions - , base64Encode + (-- * Encoding & Decoding functions + base64Encode , base64EncodeLength , base64EncodeText , base64EncodeBuilder @@ -30,38 +28,12 @@ import Control.Exception import Data.Word import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) -import Data.Hashable (Hashable(..)) import GHC.Stack import System.IO.Unsafe import qualified Z.Data.Vector.Base as V import qualified Z.Data.Builder.Base as B import qualified Z.Data.Text.Base as T -import qualified Z.Data.Text.Print as T -import qualified Z.Data.JSON as JSON import Z.Foreign - --- | New type wrapper for 'V.Bytes' with base64 encoding Show\/JSON instances. -newtype Base64Bytes = Base64Bytes { unBase64Bytes :: V.Bytes } - deriving (Eq, Ord) - deriving newtype (Monoid, Semigroup, Hashable) - -instance Show Base64Bytes where - show (Base64Bytes bs) = T.unpack $ base64EncodeText bs - -instance T.Print Base64Bytes where - {-# INLINABLE toUTF8BuilderP #-} - toUTF8BuilderP _ (Base64Bytes bs) = B.quotes (base64EncodeBuilder bs) - -instance JSON.JSON Base64Bytes where - {-# INLINE fromValue #-} - fromValue = JSON.withText "Z.Data.Text.Base64Bytes" $ \ t -> - case base64Decode (T.getUTF8Bytes t) of - Just bs -> return (Base64Bytes bs) - Nothing -> JSON.fail' "illegal base64 encoding bytes" - {-# INLINE toValue #-} - toValue (Base64Bytes bs) = JSON.String (base64EncodeText bs) - {-# INLINE encodeJSON #-} - encodeJSON (Base64Bytes bs) = base64EncodeBuilder bs -- | Encode 'V.Bytes' using base64 encoding. base64Encode :: V.Bytes -> V.Bytes diff --git a/cbits/regex.cc b/cbits/regex.cc --- a/cbits/regex.cc +++ b/cbits/regex.cc @@ -1,3 +1,30 @@ +/* +Copyright (c) 2020-2021 Dong Han +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 Johan Tibell 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 diff --git a/cbits/text.c b/cbits/text.c --- a/cbits/text.c +++ b/cbits/text.c @@ -1,3 +1,30 @@ +/* +Copyright (c) 2017-2021 Dong Han +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 Johan Tibell 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 @@ -331,6 +358,12 @@ HsInt rv = 2; // for start and end quotes const unsigned char *i = src + srcoff; const unsigned char *srcend = i + srclen; + // unroll loop for ~4% improvement + for (; i < srcend-4; ) { + rv += escape_char_length[*i] + escape_char_length[*(i+1)] + + escape_char_length[*(i+2)] + escape_char_length[*(i+3)]; + i += 4; + } for (; i < srcend; i++) { rv += escape_char_length[*i]; } diff --git a/test/Z/Data/JSON/BaseSpec.hs b/test/Z/Data/JSON/BaseSpec.hs --- a/test/Z/Data/JSON/BaseSpec.hs +++ b/test/Z/Data/JSON/BaseSpec.hs @@ -22,6 +22,7 @@ import qualified Z.Data.Text as T import qualified Z.Data.Vector as V import qualified Z.Data.Builder as B +import qualified Z.Data.CBytes as CBytes import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Calendar (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime (CalendarDiffTime (..)) @@ -47,6 +48,7 @@ | RecordII { testFour :: Double } | List [a] + | Str String deriving (Show, Eq, Generic, JSON) mid :: JSON a => a -> a @@ -103,36 +105,37 @@ \\\u001a\\u001b\\u001c\\u001d\\u001e\\u001f\"" -- tests from MessagePack suit - it "int" $ property $ \(a :: Int ) -> a `shouldBe` mid a - it "int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a - it "int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a - it "int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a - it "int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a - it "word" $ property $ \(a :: Word ) -> a `shouldBe` mid a - it "word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a - it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a - it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a - it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a + it "Int" $ property $ \(a :: Int ) -> a `shouldBe` mid a + it "Int8" $ property $ \(a :: Int8 ) -> a `shouldBe` mid a + it "Int16" $ property $ \(a :: Int16 ) -> a `shouldBe` mid a + it "Int32" $ property $ \(a :: Int32 ) -> a `shouldBe` mid a + it "Int64" $ property $ \(a :: Int64 ) -> a `shouldBe` mid a + it "Word" $ property $ \(a :: Word ) -> a `shouldBe` mid a + it "Word8" $ property $ \(a :: Word8 ) -> a `shouldBe` mid a + it "Word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a + it "Word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a + it "Word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a it "()" $ property $ \(a :: ()) -> a `shouldBe` mid a - it "bool" $ property $ \(a :: Bool) -> a `shouldBe` mid a - it "float" $ property $ \(a :: Float) -> a `shouldBe` mid a - it "double" $ property $ \(a :: Double) -> a `shouldBe` mid a - it "string" $ property $ \(a :: String) -> a `shouldBe` mid a - it "bytes" $ property $ \(a :: V.Bytes) -> a `shouldBe` mid a - it "primvector" $ property $ \(a :: V.PrimVector Int) -> a `shouldBe` mid a - it "vector" $ property $ \(a :: V.Vector [Integer]) -> a `shouldBe` mid a - it "maybe int" $ property $ \(a :: (Maybe Int)) -> a `shouldBe` mid a - it "[int]" $ property $ \(a :: [Int]) -> a `shouldBe` mid a - it "[string]" $ property $ \(a :: [String]) -> a `shouldBe` mid a - it "(int, int)" $ property $ \(a :: (Int, Int)) -> a `shouldBe` mid a - it "(int, int, int)" $ property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "(int, int, int, int, int, int, int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "[(int, double)]" $ property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a - it "[(string, string)]" $ property $ \(a :: [(String, String)]) -> a `shouldBe` mid a + it "Bool" $ property $ \(a :: Bool) -> a `shouldBe` mid a + it "Float" $ property $ \(a :: Float) -> a `shouldBe` mid a + it "Double" $ property $ \(a :: Double) -> a `shouldBe` mid a + it "String" $ property $ \(a :: String) -> a `shouldBe` mid a + it "Bytes" $ property $ \(a :: CBytes.CBytes) -> a `shouldBe` mid a + it "CByte" $ property $ \(a :: V.Bytes) -> a `shouldBe` mid a + it "PrimVector" $ property $ \(a :: V.PrimVector Int) -> a `shouldBe` mid a + it "Vector" $ property $ \(a :: V.Vector [Integer]) -> a `shouldBe` mid a + it "Maybe Int" $ property $ \(a :: (Maybe Int)) -> a `shouldBe` mid a + it "[Int]" $ property $ \(a :: [Int]) -> a `shouldBe` mid a + it "[String]" $ property $ \(a :: [String]) -> a `shouldBe` mid a + it "(Int, Int)" $ property $ \(a :: (Int, Int)) -> a `shouldBe` mid a + it "(Int, Int, Int)" $ property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a + it "(Int, Int, Int, Int)" $ property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(Int, Int, Int, Int, Int)" $ property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(Int, Int, Int, Int, Int, Int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "(Int, Int, Int, Int, Int, Int, Int)" $ property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "[(Int, Double)]" $ property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a + it "[(String, String)]" $ property $ \(a :: [(String, String)]) -> a `shouldBe` mid a it "HashMap Text Int" $ property $ \(a :: HM.HashMap T.Text Int) -> a `shouldBe` mid a it "HashSet Text" $ property $ \(a :: HS.HashSet T.Text) -> a `shouldBe` mid a it "Map Text Int" $ property $ \(a :: M.Map T.Text Int) -> a `shouldBe` mid a @@ -141,21 +144,21 @@ it "IntSet" $ property $ \(a :: IS.IntSet) -> a `shouldBe` mid a it "Seq Int" $ property $ \(a :: Seq.Seq Int) -> a `shouldBe` mid a it "Tree Int" $ property $ \(a :: Tree.Tree Int) -> a `shouldBe` mid a - it "maybe int" $ property $ \(a :: Maybe Int) -> a `shouldBe` mid a - it "maybe nil" $ property $ \(a :: Maybe ()) -> a `shouldBe` mid a - it "maybe bool" $ property $ \(a :: Maybe Bool) -> a `shouldBe` mid a - it "maybe double" $ property $ \(a :: Maybe Double) -> a `shouldBe` mid a - it "maybe string" $ property $ \(a :: Maybe String) -> a `shouldBe` mid a - it "maybe bytes" $ property $ \ (a :: Maybe V.Bytes) -> a `shouldBe` mid a - it "maybe [int]" $ property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a - it "maybe [string]" $ property $ \(a :: Maybe [String]) -> a `shouldBe` mid a - it "maybe (int, int)" $ property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a - it "maybe (int, int, int, int, int)" $ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a - it "maybe [(int, double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a - it "maybe [(string, string)]" $ property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a - it "either int float" $ property $ \(a :: Either Int Float) -> a `shouldBe` mid a + it "Maybe Int" $ property $ \(a :: Maybe Int) -> a `shouldBe` mid a + it "Maybe Nil" $ property $ \(a :: Maybe ()) -> a `shouldBe` mid a + it "Maybe Bool" $ property $ \(a :: Maybe Bool) -> a `shouldBe` mid a + it "Maybe Double" $ property $ \(a :: Maybe Double) -> a `shouldBe` mid a + it "Maybe String" $ property $ \(a :: Maybe String) -> a `shouldBe` mid a + it "Maybe Bytes" $ property $ \ (a :: Maybe V.Bytes) -> a `shouldBe` mid a + it "Maybe [Int]" $ property $ \(a :: Maybe [Int]) -> a `shouldBe` mid a + it "Maybe [String]" $ property $ \(a :: Maybe [String]) -> a `shouldBe` mid a + it "Maybe (Int, Int)" $ property $ \(a :: Maybe (Int, Int)) -> a `shouldBe` mid a + it "Maybe (Int, Int, Int)" $ property $ \(a :: Maybe (Int, Int, Int)) -> a `shouldBe` mid a + it "Maybe (Int, Int, Int, Int)" $ property $ \(a :: Maybe (Int, Int, Int, Int)) -> a `shouldBe` mid a + it "Maybe (Int, Int, Int, Int, Int)" $ property $ \(a :: Maybe (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a + it "Maybe [(Int, Double)]" $ property $ \(a :: Maybe [(Int, Double)]) -> a `shouldBe` mid a + it "Maybe [(String, String)]" $ property $ \(a :: Maybe [(String, String)]) -> a `shouldBe` mid a + it "Either Int float" $ property $ \(a :: Either Int Float) -> a `shouldBe` mid a it "Day" $ property $ \(a :: Day) -> a `shouldBe` mid a it "DiffTime" $ property $ \(a :: DiffTime) -> a `shouldBe` mid a it "LocalTime" $ property $ \(a :: LocalTime) -> a `shouldBe` mid a @@ -199,6 +202,10 @@ , Unary 123456 , (Product "ABC" (Just 'x') (123456::Integer)) , (Record 0.123456 Nothing (Just (123456::Integer)))]) + + it "List are encode as string" $ + JSON.encodeText (Str "hello" :: T ()) == encodeText' (Str "hello" :: T ()) + it "control characters are escaped" $ JSON.encodeText (T.pack $ map toEnum [0..0x1F]) === diff --git a/third_party/utf8rewind/source/utf8rewind.c b/third_party/utf8rewind/source/utf8rewind.c --- a/third_party/utf8rewind/source/utf8rewind.c +++ b/third_party/utf8rewind/source/utf8rewind.c @@ -34,6 +34,11 @@ #include "internal/seeking.h" #include "internal/streaming.h" +#if WIN32 || _WINDOWS +#include +#include +#endif + size_t utf8len(const char* text) { const uint8_t* src; @@ -556,47 +561,42 @@ https://www-01.ibm.com/support/knowledgecenter/ssw_aix_61/com.ibm.aix.nlsgdrf/support_languages_locales.htm */ -#if WIN32 || _WINDOWS - #define UTF8_LOCALE_CHECK(_name, _ansiCodepage, _oemCodepage) \ - (codepage == _ansiCodepage || codepage == _oemCodepage) - - unsigned int codepage; - _locale_t locale = _get_current_locale(); +#define UTF8_LOCALE_CHECK(_name) \ + !strncasecmp(locale, _name, 5) - if (locale == 0) +#if WIN32 || _WINDOWS + WCHAR localeW[LOCALE_NAME_MAX_LENGTH]; + size_t localeBufLen = LOCALE_NAME_MAX_LENGTH * sizeof(char); + char *locale = malloc(localeBufLen); + GetUserDefaultLocaleName(localeW, LOCALE_NAME_MAX_LENGTH); + wcstombs(locale, localeW, localeBufLen); + if (UTF8_LOCALE_CHECK("lt-lt")) { - return UTF8_LOCALE_DEFAULT; + return UTF8_LOCALE_LITHUANIAN; } - - // Microsoft changed the name of the codepage member in VS2015. - - #if _MSC_VER >= 1900 - codepage = ((__crt_locale_data_public*)(locale)->locinfo)->_locale_lc_codepage; - #else - codepage = locale->locinfo->lc_codepage; - #endif + else if ( + UTF8_LOCALE_CHECK("tr-tr") || + UTF8_LOCALE_CHECK("az-az")) + { + return UTF8_LOCALE_TURKISH_AND_AZERI_LATIN; + } #else - #define UTF8_LOCALE_CHECK(_name, _ansiCodepage, _oemCodepage) \ - !strncasecmp(locale, _name, 5) - const char* locale = setlocale(LC_ALL, 0); if (locale == 0) { return UTF8_LOCALE_DEFAULT; } -#endif - - if (UTF8_LOCALE_CHECK("lt_lt", 1257, 775)) + if (UTF8_LOCALE_CHECK("lt_lt")) { return UTF8_LOCALE_LITHUANIAN; } else if ( - UTF8_LOCALE_CHECK("tr_tr", 1254, 857) || - UTF8_LOCALE_CHECK("az_az", 1254, 857)) + UTF8_LOCALE_CHECK("tr_tr") || + UTF8_LOCALE_CHECK("az_az")) { return UTF8_LOCALE_TURKISH_AND_AZERI_LATIN; } - +#endif return UTF8_LOCALE_DEFAULT; }