diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Revision history for Z-Data +## 0.6.1.0 -- 2020-02-04 + +* Add `key` and `nth` lens to `Z.Data.JSON.Value` for manipulating nested value more easily. +* Port patch from bytestring #301 #310 #315, Improve `stime`, `sconcat`, `intersperse`. +* Add JSON pretty printer `prettyJSON/prettyValue` to `Z.Data.JSON`. +* Move many instances from `Z.Data.JSON.Base` to `Z.Data.JSON` to reduce the chance of heap overflow when compile. +* Add `modifyIndex/insertIndex/deleteIndex` to array and vector, rewrite `FlatMap/FlatSet/FlatInMap/FlatIntSet' to use them. +* Remove `linearSearch` from `Z.Data.Vector.FlatMap/FlatInMap`, use `find/findR` from `Z.Data.Vector.Search` instead. +* Add `displayWidth` to `Z.Data.Text`. +* Move `floatToScientific/doubleToScientific` to `Z.Data.JSON.Value`. + ## 0.6.0.0 -- 2020-02-04 * Add `primArrayFromBE/primArrayFromBE` to `Z.Data.Array.Unaligned`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,11 @@ ## Z-Data -[![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) +[![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/ZHaskell/z-data/workflows/ubuntu-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) +[![MacOS Build Status](https://github.com/haskell-Z/z-data/workflows/osx-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) +[![Windows Build Status](https://github.com/ZHaskell/z-data/workflows/win-ci/badge.svg)](https://github.com/ZHaskell/z-data/actions) -This package is part of [Z.Haskell](//zhaskell.github.io/docs/) project, providing basic data structures and functions: +This package is part of [ZHaskell](https://z.haskell.world) project, providing basic data structures and functions: * Array, vector(array slice), sorting, searching * Text based UTF-8, basic unicode manipulating, regex @@ -14,7 +17,7 @@ * A working haskell compiler system, GHC(>=8.6), cabal-install(>=2.4), hsc2hs. -* Tests need [hspec-discover](//hackage.haskell.org/package/hspec-discover). +* Tests need [hspec-discover](https://hackage.haskell.org/package/hspec-discover). ## Example usage @@ -77,7 +80,7 @@ ```bash # get code -git clone --recursive git@github.com:Z.Haskell/z-data.git +git clone --recursive git@github.com:ZHaskell/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,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.6.0.0 +version: 0.6.1.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -24,6 +24,7 @@ cbits/bytes.c cbits/dtoa.c cbits/text.c + cbits/text_width.c -- utf8rewind C sources third_party/utf8rewind/include/utf8rewind/utf8rewind.h @@ -172,13 +173,13 @@ Z.Data.JSON Z.Data.JSON.Base - Z.Data.JSON.Converter Z.Data.JSON.Builder + Z.Data.JSON.Converter Z.Data.JSON.Value - Z.Foreign + build-depends: base >= 4.12 && < 5.0 , bytestring >= 0.10.4 && < 0.12 , ghc-prim >= 0.5.3 && < 0.6.2 @@ -231,6 +232,7 @@ c-sources: cbits/bytes.c cbits/dtoa.c cbits/text.c + cbits/text_width.c third_party/utf8rewind/source/unicodedatabase.c third_party/utf8rewind/source/internal/casemapping.c diff --git a/Z/Data/Array.hs b/Z/Data/Array.hs --- a/Z/Data/Array.hs +++ b/Z/Data/Array.hs @@ -26,6 +26,8 @@ module Z.Data.Array ( -- * Arr typeclass Arr(..) + , singletonArr, doubletonArr + , modifyIndexArr, insertIndexArr, deleteIndexArr , RealWorld -- * Boxed array type , Array(..) @@ -37,7 +39,7 @@ , PrimArray(..) , MutablePrimArray(..) , Prim(..) - -- * Array operations + -- * Primitive Array operations , newPinnedPrimArray, newAlignedPinnedPrimArray , copyPrimArrayToPtr, copyMutablePrimArrayToPtr, copyPtrToMutablePrimArray , primArrayContents, mutablePrimArrayContents, withPrimArrayContents, withMutablePrimArrayContents @@ -57,7 +59,9 @@ ) where import Control.Exception (ArrayException (..), throw) +import Control.Monad import Control.Monad.Primitive +import Control.Monad.ST import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.PrimArray @@ -588,3 +592,63 @@ -- | Cast between mutable arrays castMutableArray :: (Arr arr a, Cast a b) => MArr arr s a -> MArr arr s b castMutableArray = unsafeCoerce# + +-------------------------------------------------------------------------------- + +singletonArr :: Arr arr a => a -> arr a +{-# INLINE singletonArr #-} +singletonArr x = runST $ do + marr <- newArrWith 1 x + unsafeFreezeArr marr + +doubletonArr :: Arr arr a => a -> a -> arr a +{-# INLINE doubletonArr #-} +doubletonArr x y = runST $ do + marr <- newArrWith 2 x + writeArr marr 1 y + unsafeFreezeArr marr + +-- | Modify(strictly) an immutable array's element at given index to produce a new array. +modifyIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ index in new array + -> (a -> a) -- ^ modify function + -> arr a +{-# INLINE modifyIndexArr #-} +modifyIndexArr arr off len ix f = runST $ do + marr <- unsafeThawArr (cloneArr arr off len) + !v <- f <$> readArr marr ix + writeArr marr ix v + unsafeFreezeArr marr + +-- | Insert an immutable array's element at given index to produce a new array. +insertIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ insert index in new array + -> a -- ^ element to be inserted + -> arr a +{-# INLINE insertIndexArr #-} +insertIndexArr arr s l i x = runST $ do + marr <- newArrWith (l+1) x + when (i>0) $ copyArr marr 0 arr s i + when (i arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ drop index in new array + -> arr a +{-# INLINE deleteIndexArr #-} +deleteIndexArr arr s l i = runST $ do + marr <- newArr (l-1) + when (i>0) $ copyArr marr 0 arr s i + let i' = i+1 + when (i' Bool -> a -> a @@ -83,18 +88,18 @@ check True x = x check False _ = throw (IndexOutOfBounds $ show callStack) -newArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => Int -> m (A.MArr arr s a) +newArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => Int -> m (MArr arr s a) newArr n = check (n>=0) (A.newArr n) {-# INLINE newArr #-} -newArrWith :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => Int -> a -> m (A.MArr arr s a) +newArrWith :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => Int -> a -> m (MArr arr s a) newArrWith n x = check (n>=0) (A.newArrWith n x) {-# INLINE newArrWith #-} -readArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> m a +readArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m a readArr marr i = do siz <- A.sizeofMutableArr marr check @@ -102,8 +107,8 @@ (A.readArr marr i) {-# INLINE readArr #-} -writeArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> a -> m () +writeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> a -> m () writeArr marr i x = do siz <- A.sizeofMutableArr marr check @@ -111,8 +116,8 @@ (A.writeArr marr i x) {-# INLINE writeArr #-} -setArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> Int -> a -> m () +setArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> Int -> a -> m () setArr marr s l x = do siz <- A.sizeofMutableArr marr check @@ -120,14 +125,14 @@ (A.setArr marr s l x) {-# INLINE setArr #-} -indexArr :: (A.Arr arr a, HasCallStack) +indexArr :: (Arr arr a, HasCallStack) => arr a -> Int -> a indexArr arr i = check (i>=0 && i arr a -> Int -> (# a #) indexArr' arr i = if (i>=0 && i arr a -> Int -> m a indexArrM arr i = check (i>=0 && i A.MArr arr s a -> Int -> Int -> m (arr a) +freezeArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> Int -> m (arr a) freezeArr marr s l = do siz <- A.sizeofMutableArr marr check @@ -151,15 +156,15 @@ (A.freezeArr marr s l) {-# INLINE freezeArr #-} -thawArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => arr a -> Int -> Int -> m (A.MArr arr s a) +thawArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => arr a -> Int -> Int -> m (MArr arr s a) thawArr arr s l = check (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) (A.thawArr arr s l) {-# INLINE thawArr #-} -copyArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> arr a -> Int -> Int -> m () +copyArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> arr a -> Int -> Int -> m () copyArr marr s1 arr s2 l = do siz <- A.sizeofMutableArr marr check @@ -167,8 +172,8 @@ (A.copyArr marr s1 arr s2 l) {-# INLINE copyArr #-} -copyMutableArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> A.MArr arr s a -> Int -> Int -> m () +copyMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () copyMutableArr marr1 s1 marr2 s2 l = do siz1 <- A.sizeofMutableArr marr1 siz2 <- A.sizeofMutableArr marr2 @@ -177,8 +182,8 @@ (A.copyMutableArr marr1 s1 marr2 s2 l) {-# INLINE copyMutableArr #-} -moveArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> A.MArr arr s a -> Int -> Int -> m () +moveArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> MArr arr s a -> Int -> Int -> m () moveArr marr1 s1 marr2 s2 l = do siz1 <- A.sizeofMutableArr marr1 siz2 <- A.sizeofMutableArr marr2 @@ -187,15 +192,15 @@ (A.copyMutableArr marr1 s1 marr2 s2 l) {-# INLINE moveArr #-} -cloneArr :: (A.Arr arr a, HasCallStack) +cloneArr :: (Arr arr a, HasCallStack) => arr a -> Int -> Int -> arr a cloneArr arr s l = check (s>=0 && l>=0 && (s+l)<=A.sizeofArr arr) (A.cloneArr arr s l) {-# INLINE cloneArr #-} -cloneMutableArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> Int -> m (A.MArr arr s a) +cloneMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> Int -> m (MArr arr s a) cloneMutableArr marr s l = do siz <- A.sizeofMutableArr marr check @@ -203,8 +208,8 @@ (A.cloneMutableArr marr s l) {-# INLINE cloneMutableArr #-} -resizeMutableArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> m (A.MArr arr s a) +resizeMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m (MArr arr s a) resizeMutableArr marr n = check (n>=0) (A.resizeMutableArr marr n) @@ -212,8 +217,8 @@ -- | New size should be >= 0, and <= original size. -- -shrinkMutableArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) - => A.MArr arr s a -> Int -> m () +shrinkMutableArr :: (Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack) + => MArr arr s a -> Int -> m () shrinkMutableArr marr n = do siz <- A.sizeofMutableArr marr check @@ -276,3 +281,48 @@ check (s>=0 && l>=0 && (s+l)<=siz) (A.copyPtrToMutablePrimArray marr s ptr l) + +-------------------------------------------------------------------------------- + +modifyIndexArr :: (Arr arr a, HasCallStack) => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ index in new array + -> (a -> a) -- ^ modify function + -> arr a +{-# INLINE modifyIndexArr #-} +modifyIndexArr arr off len ix f = runST $ do + marr <- A.unsafeThawArr (cloneArr arr off len) + !v <- f <$> readArr marr ix + writeArr marr ix v + A.unsafeFreezeArr marr + +-- | Insert an immutable array's element at given index to produce a new array. +insertIndexArr :: Arr arr a + => arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ insert index in new array + -> a -- ^ element to be inserted + -> arr a +{-# INLINE insertIndexArr #-} +insertIndexArr arr s l i x = runST $ do + marr <- newArrWith (l+1) x + when (i>0) $ copyArr marr 0 arr s i + when (i arr a + -> Int -- ^ offset + -> Int -- ^ length + -> Int -- ^ drop index in new array + -> arr a +{-# INLINE deleteIndexArr #-} +deleteIndexArr arr s l i = runST $ do + marr <- newArr (l-1) + when (i>0) $ copyArr marr 0 arr s i + let i' = i+1 + when (i' (# s1, MutablePrimArray (unsafeCoerce# x) #) indexUnliftedArray# a i = MutablePrimArray (unsafeCoerce# (indexByteArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of all of its --- methods. See the note for the PrimUnlifted instance of --- Data.Primitive.MVar.MVar. instance PrimUnlifted (MVar a) where {-# inline writeUnliftedArray# #-} {-# inline readUnliftedArray# #-} @@ -111,9 +109,16 @@ (# s1, x #) -> (# s1, MVar (unsafeCoerce# x) #) indexUnliftedArray# a i = MVar (unsafeCoerce# (indexArrayArrayArray# a i)) --- This uses unsafeCoerce# in the implementation of all of its --- methods. This does not lead to corruption FFI codegen since ArrayArray# --- and MutVar# have the same FFI offset applied by add_shim. +instance PrimUnlifted (TVar a) where + {-# inline writeUnliftedArray# #-} + {-# inline readUnliftedArray# #-} + {-# inline indexUnliftedArray# #-} + writeUnliftedArray# a i (TVar x) = + writeArrayArrayArray# a i (unsafeCoerce# x) + readUnliftedArray# a i s0 = case readArrayArrayArray# a i s0 of + (# s1, x #) -> (# s1, TVar (unsafeCoerce# x) #) + indexUnliftedArray# a i = TVar (unsafeCoerce# (indexArrayArrayArray# a i)) + instance PrimUnlifted (STRef s a) where {-# inline writeUnliftedArray# #-} {-# inline readUnliftedArray# #-} diff --git a/Z/Data/Builder.hs b/Z/Data/Builder.hs --- a/Z/Data/Builder.hs +++ b/Z/Data/Builder.hs @@ -34,7 +34,8 @@ , encodePrimLE , encodePrimBE -- * More builders - , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, word7, string8, char8, word8, text + , stringModifiedUTF8, charModifiedUTF8, stringUTF8 + , charUTF8, string7, char7, word7, string8, char8, word8, word8N, text -- * Numeric builders -- ** Integral type formatting , IFormat(..) 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 @@ -46,7 +46,8 @@ , encodePrimLE , encodePrimBE -- * More builders - , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, word7, string8, char8, word8, text + , stringModifiedUTF8, charModifiedUTF8, stringUTF8 + , charUTF8, string7, char7, word7, string8, char8, word8, word8N, text -- * Builder helpers , paren, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList ) where @@ -467,6 +468,15 @@ word8 :: Word8 -> Builder () {-# INLINE word8 #-} word8 = encodePrim + +-- | Faster version of @replicateM x . word8@ by using @memset@. +-- +-- Note, this encoding is NOT compatible with UTF8 encoding, i.e. bytes written +-- by this builder may not be legal UTF8 encoding bytes. +word8N :: Int -> Word8 -> Builder () +{-# INLINE word8N #-} +word8N x w8 = do + writeN x (\ mpa i -> setPrimArray mpa i x w8) -- | Write UTF8 encoded 'Text' using '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 @@ -690,11 +690,11 @@ encodeDigit d (unless (List.null ds') $ encodePrim DOT >> encodeDigits ds') where - encodeDigit = encodePrim . i2wDec + encodeDigit = word8 . i2wDec encodeDigits = mapM_ encodeDigit - encodeZeros n = replicateM_ n (encodePrim DIGIT_0) + encodeZeros n = word8N n DIGIT_0 mk0 [] = encodePrim DIGIT_0 mk0 ls = encodeDigits ls diff --git a/Z/Data/Generics/Utils.hs b/Z/Data/Generics/Utils.hs --- a/Z/Data/Generics/Utils.hs +++ b/Z/Data/Generics/Utils.hs @@ -32,4 +32,5 @@ type PSize (a :*: b) = PSize a + PSize b productSize :: forall f. KnownNat (PSize f) => Proxy# f -> Int +{-# INLINE productSize #-} productSize _ = fromIntegral (natVal' (proxy# :: Proxy# (PSize f))) diff --git a/Z/Data/JSON.hs b/Z/Data/JSON.hs --- a/Z/Data/JSON.hs +++ b/Z/Data/JSON.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module : Z.Data.JSON Description : Fast JSON serialization/deserialization @@ -13,6 +15,8 @@ * Decode are split in two step, first we parse JSON doc into 'Value', then convert to haskell data via 'fromValue'. * 'ToValue' are provided so that other doc formats can be easily supported, such as 'YAML'. +Note this module also provides many (orphan)instances to reduce the compilation stress of a gaint 'Z.Data.JSON.Base' module. + -} module Z.Data.JSON ( -- * How to use this module @@ -27,8 +31,10 @@ , snakeCase, trainCase -- * Encode & Decode , DecodeError - , decode, decode', decodeText, decodeText', ParseChunks, decodeChunks + , decode, decode', decodeText, decodeText' + , ParseChunks, decodeChunks , encode, encodeChunks, encodeText + , prettyJSON, prettyValue -- * parse into JSON Value , parseValue, parseValue', parseValueChunks -- * Generic functions @@ -45,8 +51,28 @@ ) where import Data.Char +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy (..)) +import Data.Scientific (toBoundedInteger) +import qualified Data.Semigroup as Semigroup +import Data.Tagged (Tagged (..)) +import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time.Calendar (CalendarDiffDays (..), DayOfWeek (..)) +import Data.Time.LocalTime (CalendarDiffTime (..)) +import Data.Time.Clock.System (SystemTime (..)) +import Data.Version (Version(versionBranch), makeVersion) +import Foreign.C.Types +import System.Exit (ExitCode(..)) +import qualified Z.Data.Builder as B import Z.Data.JSON.Base -import qualified Z.Data.Text as T +import qualified Z.Data.JSON.Builder as JB +import qualified Z.Data.Parser as P +import qualified Z.Data.Text as T -- $use -- @@ -191,3 +217,242 @@ applyFirst _ [] = [] applyFirst f (x:xs) = f x: xs + +-------------------------------------------------------------------------------- + +instance JSON ExitCode where + {-# INLINE fromValue #-} + fromValue (String "ExitSuccess") = return ExitSuccess + fromValue (Number x) = + case toBoundedInteger x of + Just i -> return (ExitFailure i) + _ -> fail' . B.unsafeBuildText $ do + "converting ExitCode failed, value is either floating or will cause over or underflow: " + B.scientific x + fromValue _ = fail' "converting ExitCode failed, expected a string or number" + + {-# INLINE toValue #-} + toValue ExitSuccess = String "ExitSuccess" + toValue (ExitFailure n) = Number (fromIntegral n) + + {-# INLINE encodeJSON #-} + encodeJSON ExitSuccess = "\"ExitSuccess\"" + encodeJSON (ExitFailure n) = B.int n + +-- | Only round trip 'versionBranch' as JSON array. +instance JSON Version where + {-# INLINE fromValue #-} + fromValue v = makeVersion <$> fromValue v + {-# INLINE toValue #-} + toValue = toValue . versionBranch + {-# INLINE encodeJSON #-} + encodeJSON = encodeJSON . versionBranch + +-------------------------------------------------------------------------------- + +-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance JSON UTCTime where + {-# INLINE fromValue #-} + fromValue = withText "UTCTime" $ \ t -> + case P.parse' (P.utcTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as UTCTime: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.utcTime t)) + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.utcTime + +-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance JSON ZonedTime where + {-# INLINE fromValue #-} + fromValue = withText "ZonedTime" $ \ t -> + case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.zonedTime t)) + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.zonedTime + +-- | @YYYY-MM-DD@ +instance JSON Day where + {-# INLINE fromValue #-} + fromValue = withText "Day" $ \ t -> + case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as Day: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.day t)) + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.day + + +-- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance JSON LocalTime where + {-# INLINE fromValue #-} + fromValue = withText "LocalTime" $ \ t -> + case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.localTime t)) + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.localTime + +-- | @HH:MM:SS.SSS@ +instance JSON TimeOfDay where + {-# INLINE fromValue #-} + fromValue = withText "TimeOfDay" $ \ t -> + case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err + Right r -> return r + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.timeOfDay t)) + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.timeOfDay + +-- | This instance includes a bounds check to prevent maliciously +-- large inputs to fill up the memory of the target system. You can +-- newtype 'NominalDiffTime' and provide your own instance using +-- 'withScientific' if you want to allow larger inputs. +instance JSON NominalDiffTime where + {-# INLINE fromValue #-} + fromValue = withBoundedScientific "NominalDiffTime" $ pure . realToFrac + {-# INLINE toValue #-} + toValue = Number . realToFrac + {-# INLINE encodeJSON #-} + encodeJSON = JB.scientific . realToFrac + +-- | This instance includes a bounds check to prevent maliciously +-- large inputs to fill up the memory of the target system. You can +-- newtype 'DiffTime' and provide your own instance using +-- 'withScientific' if you want to allow larger inputs. +instance JSON DiffTime where + {-# INLINE fromValue #-} + fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac + {-# INLINE toValue #-} + toValue = Number . realToFrac + {-# INLINE encodeJSON #-} + encodeJSON = JB.scientific . realToFrac + +-- | @{"seconds": SSS, "nanoseconds": NNN}@. +instance JSON SystemTime where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "SystemTime" $ \ v -> + MkSystemTime <$> v .: "seconds" <*> v .: "nanoseconds" + {-# INLINE toValue #-} + toValue (MkSystemTime s ns) = object [ "seconds" .= s , "nanoseconds" .= ns ] + {-# INLINE encodeJSON #-} + encodeJSON (MkSystemTime s ns) = object' ("seconds" .! s <> "nanoseconds" .! ns) + +instance JSON CalendarDiffTime where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "CalendarDiffTime" $ \ v -> + CalendarDiffTime <$> v .: "months" <*> v .: "time" + {-# INLINE toValue #-} + toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ] + {-# INLINE encodeJSON #-} + encodeJSON (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt) + +instance JSON CalendarDiffDays where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "CalendarDiffDays" $ \ v -> + CalendarDiffDays <$> v .: "months" <*> v .: "days" + {-# INLINE toValue #-} + toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d] + {-# INLINE encodeJSON #-} + encodeJSON (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d) + +instance JSON DayOfWeek where + {-# INLINE fromValue #-} + fromValue (String "Monday" ) = pure Monday + fromValue (String "Tuesday" ) = pure Tuesday + fromValue (String "Wednesday") = pure Wednesday + fromValue (String "Thursday" ) = pure Thursday + fromValue (String "Friday" ) = pure Friday + fromValue (String "Saturday" ) = pure Saturday + fromValue (String "Sunday" ) = pure Sunday + fromValue (String _ ) = fail' "converting DayOfWeek failed, value should be one of weekdays" + fromValue v = typeMismatch "DayOfWeek" "String" v + + {-# INLINE toValue #-} + toValue Monday = String "Monday" + toValue Tuesday = String "Tuesday" + toValue Wednesday = String "Wednesday" + toValue Thursday = String "Thursday" + toValue Friday = String "Friday" + toValue Saturday = String "Saturday" + toValue Sunday = String "Sunday" + + {-# INLINE encodeJSON #-} + encodeJSON Monday = "\"Monday\"" + encodeJSON Tuesday = "\"Tuesday\"" + encodeJSON Wednesday = "\"Wednesday\"" + encodeJSON Thursday = "\"Thursday\"" + encodeJSON Friday = "\"Friday\"" + encodeJSON Saturday = "\"Saturday\"" + encodeJSON Sunday = "\"Sunday\"" + + +-------------------------------------------------------------------------------- + +deriving newtype instance JSON (f (g a)) => JSON (Compose f g a) +deriving newtype instance JSON a => JSON (Semigroup.Min a) +deriving newtype instance JSON a => JSON (Semigroup.Max a) +deriving newtype instance JSON a => JSON (Semigroup.First a) +deriving newtype instance JSON a => JSON (Semigroup.Last a) +deriving newtype instance JSON a => JSON (Semigroup.WrappedMonoid a) +deriving newtype instance JSON a => JSON (Semigroup.Dual a) +deriving newtype instance JSON a => JSON (Monoid.First a) +deriving newtype instance JSON a => JSON (Monoid.Last a) +deriving newtype instance JSON a => JSON (Identity a) +deriving newtype instance JSON a => JSON (Const a b) +deriving newtype instance JSON b => JSON (Tagged a b) + +-- | Use 'Null' as @Proxy a@ +instance JSON (Proxy a) where + {-# INLINE fromValue #-}; fromValue = fromNull "Proxy" Proxy; + {-# INLINE toValue #-}; toValue _ = Null; + {-# INLINE encodeJSON #-}; encodeJSON _ = "null"; + +-------------------------------------------------------------------------------- + +deriving newtype instance JSON CChar +deriving newtype instance JSON CSChar +deriving newtype instance JSON CUChar +deriving newtype instance JSON CShort +deriving newtype instance JSON CUShort +deriving newtype instance JSON CInt +deriving newtype instance JSON CUInt +deriving newtype instance JSON CLong +deriving newtype instance JSON CULong +deriving newtype instance JSON CPtrdiff +deriving newtype instance JSON CSize +deriving newtype instance JSON CWchar +deriving newtype instance JSON CSigAtomic +deriving newtype instance JSON CLLong +deriving newtype instance JSON CULLong +deriving newtype instance JSON CBool +deriving newtype instance JSON CIntPtr +deriving newtype instance JSON CUIntPtr +deriving newtype instance JSON CIntMax +deriving newtype instance JSON CUIntMax +deriving newtype instance JSON CClock +deriving newtype instance JSON CTime +deriving newtype instance JSON CUSeconds +deriving newtype instance JSON CSUSeconds +deriving newtype instance JSON CFloat +deriving newtype instance JSON CDouble + +-------------------------------------------------------------------------------- + +deriving anyclass instance (JSON (f a), JSON (g a), JSON a) => JSON (Sum f g a) +deriving anyclass instance (JSON a, JSON b) => JSON (Either a b) +deriving anyclass instance (JSON (f a), JSON (g a)) => JSON (Product f g a) + +deriving anyclass instance (JSON a, JSON b) => JSON (a, b) +deriving anyclass instance (JSON a, JSON b, JSON c) => JSON (a, b, c) +deriving anyclass instance (JSON a, JSON b, JSON c, JSON d) => JSON (a, b, c, d) +deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e) => JSON (a, b, c, d, e) +deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f) => JSON (a, b, c, d, e, f) +deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f, JSON g) => JSON (a, b, c, d, e, f, g) 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 @@ -8,7 +8,7 @@ Portability : non-portable This module provides 'Converter' to convert 'Value' to haskell data types, and various tools to help -user define 'JSON' instance. +user define 'JSON' instance. It's recommended to use "Z.Data.JSON" instead since it contain more instances. -} @@ -17,8 +17,10 @@ JSON(..), Value(..), defaultSettings, Settings(..) , -- * Encode & Decode DecodeError - , decode, decode', decodeText, decodeText', P.ParseChunks, decodeChunks + , decode, decode', decodeText, decodeText' + , P.ParseChunks, decodeChunks , encode, encodeChunks, encodeText + , prettyJSON, JB.prettyValue -- * parse into JSON Value , JV.parseValue, JV.parseValue', JV.parseValueChunks -- * Generic functions @@ -43,13 +45,7 @@ import Control.Monad import Control.Monad.ST import Data.Char (ord) -import Data.Data import Data.Fixed -import Data.Functor.Compose -import Data.Functor.Const -import Data.Functor.Identity -import Data.Functor.Product -import Data.Functor.Sum import Data.Hashable import qualified Data.Foldable as Foldable import qualified Data.HashMap.Strict as HM @@ -63,27 +59,16 @@ import Data.Int import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Monoid as Monoid import qualified Data.Primitive.ByteArray as A import qualified Data.Primitive.SmallArray as A import Data.Primitive.Types (Prim) -import Data.Proxy (Proxy (..)) import Data.Ratio (Ratio, denominator, numerator, (%)) import Data.Scientific (Scientific, base10Exponent, toBoundedInteger) import qualified Data.Scientific as Scientific -import qualified Data.Semigroup as Semigroup -import Data.Tagged (Tagged (..)) -import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) -import Data.Time.Calendar (CalendarDiffDays (..), DayOfWeek (..)) -import Data.Time.LocalTime (CalendarDiffTime (..)) -import Data.Time.Clock.System (SystemTime (..)) -import Data.Version (Version(versionBranch), makeVersion) import Data.Word -import Foreign.C.Types import GHC.Exts (Proxy#, proxy#) import GHC.Generics import GHC.Natural -import System.Exit import qualified Z.Data.Array as A import qualified Z.Data.Builder as B import Z.Data.Generics.Utils @@ -92,9 +77,8 @@ import Z.Data.JSON.Value (Value (..)) import qualified Z.Data.JSON.Value as JV import qualified Z.Data.Parser as P -import qualified Z.Data.Parser.Numeric as P -import qualified Z.Data.Text.Base as T import qualified Z.Data.Text as T +import qualified Z.Data.Text.Base 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 @@ -193,6 +177,11 @@ {-# INLINE convertValue #-} convertValue = convert fromValue +-- | Directly encode data to JSON bytes. +prettyJSON :: JSON a => a -> B.Builder () +{-# INLINE prettyJSON #-} +prettyJSON = JB.prettyValue . toValue + -------------------------------------------------------------------------------- -- | Produce an error message like @converting XXX failed, expected XXX, encountered XXX@. @@ -811,11 +800,6 @@ -------------------------------------------------------------------------------- -- Built-in Instances -------------------------------------------------------------------------------- --- | Use 'Null' as @Proxy a@ -instance JSON (Proxy a) where - {-# INLINE fromValue #-}; fromValue = fromNull "Proxy" Proxy; - {-# INLINE toValue #-}; toValue _ = Null; - {-# INLINE encodeJSON #-}; encodeJSON _ = "null"; instance JSON Value where {-# INLINE fromValue #-}; fromValue = pure; @@ -1099,7 +1083,8 @@ -- \'\\t\': \"\\t\" -- \'\"\': \"\\\"\" -- \'\\\': \"\\\\\" --- other chars <= 0x1F: "\\u00XX" +-- \'\DEL\': \"\\u007f\" +-- other chars <= 0x1F: "\\u00xx" -- @ {-# INLINE encodeJSON #-} encodeJSON '\b' = "\"\\b\"" @@ -1115,11 +1100,11 @@ instance JSON Double where {-# INLINE fromValue #-}; fromValue = withRealFloat "Double" pure; - {-# INLINE toValue #-}; toValue = Number . P.doubleToScientific; + {-# INLINE toValue #-}; toValue = Number . JV.doubleToScientific; {-# INLINE encodeJSON #-}; encodeJSON = B.double; instance JSON Float where {-# INLINE fromValue #-}; fromValue = withRealFloat "Float" pure; - {-# INLINE toValue #-}; toValue = Number . P.floatToScientific; + {-# INLINE toValue #-}; toValue = Number . JV.floatToScientific; {-# INLINE encodeJSON #-}; encodeJSON = B.float; #define INT_JSON_INSTANCE(typ) \ @@ -1200,34 +1185,6 @@ {-# INLINE encodeJSON #-} encodeJSON () = "[]" -instance JSON ExitCode where - {-# INLINE fromValue #-} - fromValue (String "ExitSuccess") = return ExitSuccess - fromValue (Number x) = - case toBoundedInteger x of - Just i -> return (ExitFailure i) - _ -> fail' . B.unsafeBuildText $ do - "converting ExitCode failed, value is either floating or will cause over or underflow: " - T.scientific x - fromValue _ = fail' "converting ExitCode failed, expected a string or number" - - {-# INLINE toValue #-} - toValue ExitSuccess = String "ExitSuccess" - toValue (ExitFailure n) = Number (fromIntegral n) - - {-# INLINE encodeJSON #-} - encodeJSON ExitSuccess = "\"ExitSuccess\"" - encodeJSON (ExitFailure n) = B.int n - --- | Only round trip 'versionBranch' as JSON array. -instance JSON Version where - {-# INLINE fromValue #-} - fromValue v = makeVersion <$> fromValue v - {-# INLINE toValue #-} - toValue = toValue . versionBranch - {-# INLINE encodeJSON #-} - encodeJSON = encodeJSON . versionBranch - instance JSON a => JSON (Maybe a) where {-# INLINE fromValue #-} fromValue Null = pure Nothing @@ -1261,205 +1218,3 @@ toValue = Number . realToFrac {-# INLINE encodeJSON #-} encodeJSON = JB.scientific . realToFrac - --------------------------------------------------------------------------------- - --- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ -instance JSON UTCTime where - {-# INLINE fromValue #-} - fromValue = withText "UTCTime" $ \ t -> - case P.parse' (P.utcTime <* P.endOfInput) (T.getUTF8Bytes t) of - Left err -> fail' $ "could not parse date as UTCTime: " <> T.toText err - Right r -> return r - {-# INLINE toValue #-} - toValue t = String (B.unsafeBuildText (B.utcTime t)) - {-# INLINE encodeJSON #-} - encodeJSON = B.quotes . B.utcTime - --- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ -instance JSON ZonedTime where - {-# INLINE fromValue #-} - fromValue = withText "ZonedTime" $ \ t -> - case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of - Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err - Right r -> return r - {-# INLINE toValue #-} - toValue t = String (B.unsafeBuildText (B.zonedTime t)) - {-# INLINE encodeJSON #-} - encodeJSON = B.quotes . B.zonedTime - --- | @YYYY-MM-DD@ -instance JSON Day where - {-# INLINE fromValue #-} - fromValue = withText "Day" $ \ t -> - case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of - Left err -> fail' $ "could not parse date as Day: " <> T.toText err - Right r -> return r - {-# INLINE toValue #-} - toValue t = String (B.unsafeBuildText (B.day t)) - {-# INLINE encodeJSON #-} - encodeJSON = B.quotes . B.day - - --- | @YYYY-MM-DDTHH:MM:SS.SSSZ@ -instance JSON LocalTime where - {-# INLINE fromValue #-} - fromValue = withText "LocalTime" $ \ t -> - case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of - Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err - Right r -> return r - {-# INLINE toValue #-} - toValue t = String (B.unsafeBuildText (B.localTime t)) - {-# INLINE encodeJSON #-} - encodeJSON = B.quotes . B.localTime - --- | @HH:MM:SS.SSS@ -instance JSON TimeOfDay where - {-# INLINE fromValue #-} - fromValue = withText "TimeOfDay" $ \ t -> - case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of - Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err - Right r -> return r - {-# INLINE toValue #-} - toValue t = String (B.unsafeBuildText (B.timeOfDay t)) - {-# INLINE encodeJSON #-} - encodeJSON = B.quotes . B.timeOfDay - --- | This instance includes a bounds check to prevent maliciously --- large inputs to fill up the memory of the target system. You can --- newtype 'NominalDiffTime' and provide your own instance using --- 'withScientific' if you want to allow larger inputs. -instance JSON NominalDiffTime where - {-# INLINE fromValue #-} - fromValue = withBoundedScientific "NominalDiffTime" $ pure . realToFrac - {-# INLINE toValue #-} - toValue = Number . realToFrac - {-# INLINE encodeJSON #-} - encodeJSON = JB.scientific . realToFrac - --- | This instance includes a bounds check to prevent maliciously --- large inputs to fill up the memory of the target system. You can --- newtype 'DiffTime' and provide your own instance using --- 'withScientific' if you want to allow larger inputs. -instance JSON DiffTime where - {-# INLINE fromValue #-} - fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac - {-# INLINE toValue #-} - toValue = Number . realToFrac - {-# INLINE encodeJSON #-} - encodeJSON = JB.scientific . realToFrac - --- | @{"seconds": SSS, "nanoseconds": NNN}@. -instance JSON SystemTime where - {-# INLINE fromValue #-} - fromValue = withFlatMapR "SystemTime" $ \ v -> - MkSystemTime <$> v .: "seconds" <*> v .: "nanoseconds" - {-# INLINE toValue #-} - toValue (MkSystemTime s ns) = object [ "seconds" .= s , "nanoseconds" .= ns ] - {-# INLINE encodeJSON #-} - encodeJSON (MkSystemTime s ns) = object' ("seconds" .! s <> "nanoseconds" .! ns) - -instance JSON CalendarDiffTime where - {-# INLINE fromValue #-} - fromValue = withFlatMapR "CalendarDiffTime" $ \ v -> - CalendarDiffTime <$> v .: "months" <*> v .: "time" - {-# INLINE toValue #-} - toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ] - {-# INLINE encodeJSON #-} - encodeJSON (CalendarDiffTime m nt) = object' ("months" .! m <> "time" .! nt) - -instance JSON CalendarDiffDays where - {-# INLINE fromValue #-} - fromValue = withFlatMapR "CalendarDiffDays" $ \ v -> - CalendarDiffDays <$> v .: "months" <*> v .: "days" - {-# INLINE toValue #-} - toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d] - {-# INLINE encodeJSON #-} - encodeJSON (CalendarDiffDays m d) = object' ("months" .! m <> "days" .! d) - -instance JSON DayOfWeek where - {-# INLINE fromValue #-} - fromValue (String "Monday" ) = pure Monday - fromValue (String "Tuesday" ) = pure Tuesday - fromValue (String "Wednesday") = pure Wednesday - fromValue (String "Thursday" ) = pure Thursday - fromValue (String "Friday" ) = pure Friday - fromValue (String "Saturday" ) = pure Saturday - fromValue (String "Sunday" ) = pure Sunday - fromValue (String _ ) = fail' "converting DayOfWeek failed, value should be one of weekdays" - fromValue v = typeMismatch "DayOfWeek" "String" v - - {-# INLINE toValue #-} - toValue Monday = String "Monday" - toValue Tuesday = String "Tuesday" - toValue Wednesday = String "Wednesday" - toValue Thursday = String "Thursday" - toValue Friday = String "Friday" - toValue Saturday = String "Saturday" - toValue Sunday = String "Sunday" - - {-# INLINE encodeJSON #-} - encodeJSON Monday = "\"Monday\"" - encodeJSON Tuesday = "\"Tuesday\"" - encodeJSON Wednesday = "\"Wednesday\"" - encodeJSON Thursday = "\"Thursday\"" - encodeJSON Friday = "\"Friday\"" - encodeJSON Saturday = "\"Saturday\"" - encodeJSON Sunday = "\"Sunday\"" - --------------------------------------------------------------------------------- - -deriving newtype instance JSON (f (g a)) => JSON (Compose f g a) -deriving newtype instance JSON a => JSON (Semigroup.Min a) -deriving newtype instance JSON a => JSON (Semigroup.Max a) -deriving newtype instance JSON a => JSON (Semigroup.First a) -deriving newtype instance JSON a => JSON (Semigroup.Last a) -deriving newtype instance JSON a => JSON (Semigroup.WrappedMonoid a) -deriving newtype instance JSON a => JSON (Semigroup.Dual a) -deriving newtype instance JSON a => JSON (Monoid.First a) -deriving newtype instance JSON a => JSON (Monoid.Last a) -deriving newtype instance JSON a => JSON (Identity a) -deriving newtype instance JSON a => JSON (Const a b) -deriving newtype instance JSON b => JSON (Tagged a b) - --------------------------------------------------------------------------------- - -deriving newtype instance JSON CChar -deriving newtype instance JSON CSChar -deriving newtype instance JSON CUChar -deriving newtype instance JSON CShort -deriving newtype instance JSON CUShort -deriving newtype instance JSON CInt -deriving newtype instance JSON CUInt -deriving newtype instance JSON CLong -deriving newtype instance JSON CULong -deriving newtype instance JSON CPtrdiff -deriving newtype instance JSON CSize -deriving newtype instance JSON CWchar -deriving newtype instance JSON CSigAtomic -deriving newtype instance JSON CLLong -deriving newtype instance JSON CULLong -deriving newtype instance JSON CBool -deriving newtype instance JSON CIntPtr -deriving newtype instance JSON CUIntPtr -deriving newtype instance JSON CIntMax -deriving newtype instance JSON CUIntMax -deriving newtype instance JSON CClock -deriving newtype instance JSON CTime -deriving newtype instance JSON CUSeconds -deriving newtype instance JSON CSUSeconds -deriving newtype instance JSON CFloat -deriving newtype instance JSON CDouble - --------------------------------------------------------------------------------- - -deriving anyclass instance (JSON (f a), JSON (g a), JSON a) => JSON (Sum f g a) -deriving anyclass instance (JSON a, JSON b) => JSON (Either a b) -deriving anyclass instance (JSON (f a), JSON (g a)) => JSON (Product f g a) - -deriving anyclass instance (JSON a, JSON b) => JSON (a, b) -deriving anyclass instance (JSON a, JSON b, JSON c) => JSON (a, b, c) -deriving anyclass instance (JSON a, JSON b, JSON c, JSON d) => JSON (a, b, c, d) -deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e) => JSON (a, b, c, d, e) -deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f) => JSON (a, b, c, d, e, f) -deriving anyclass instance (JSON a, JSON b, JSON c, JSON d, JSON e, JSON f, JSON g) => JSON (a, b, c, d, e, f, g) diff --git a/Z/Data/JSON/Builder.hs b/Z/Data/JSON/Builder.hs --- a/Z/Data/JSON/Builder.hs +++ b/Z/Data/JSON/Builder.hs @@ -19,6 +19,8 @@ , array' , string , scientific + , prettyValue + , prettyValue' -- * Builder helpers , kv, kv' -- * Re-export 'Value' type @@ -83,6 +85,7 @@ -- \'\\t\': \"\\t\" -- \'\"\': \"\\\"\" -- \'\\\': \"\\\\\" +-- \'\DEL\': \"\\u007f\" -- other chars <= 0x1F: "\\u00XX" -- @ -- @@ -90,11 +93,11 @@ {-# INLINE string #-} string = T.escapeTextJSON --- | This builder try to render integer when (0 <= e < 1024), and scientific notation otherwise. +-- | This builder try to render integer when (0 <= e < 16), and scientific notation otherwise. scientific :: Scientific -> B.Builder () {-# INLINE scientific #-} scientific s - | e < 0 || e >= 1024 = B.scientific s + | e < 0 || e >= 16 = B.scientific s | e == 0 = B.integer c | otherwise = do B.integer c @@ -102,3 +105,107 @@ where e = base10Exponent s c = coefficient s + +-------------------------------------------------------------------------------- + +-- | 'ValuePretty\'' with 4 spaces indentation per level, e.g. +-- +-- @ +-- { +-- "results": +-- [ +-- { +-- "from_user_id_str":"80430860", +-- "profile_image_url":"http://a2.twimg.com/profile_images/536455139/icon32_normal.png", +-- "created_at":"Wed, 26 Jan 2011 07:07:02 +0000", +-- "from_user":"kazu_yamamoto", +-- "id_str":"30159761706061824", +-- "metadata": +-- { +-- "result_type":"recent" +-- }, +-- "to_user_id":null, +-- "text":"Haskell Server Pages って、まだ続いていたのか！", +-- "id":30159761706061824, +-- "from_user_id":80430860, +-- "geo":null, +-- "iso_language_code":"no", +-- "to_user_id_str":null, +-- "source":"<a href="http://twitter.com/">web</a>" +-- } +-- ], +-- "max_id":30159761706061824, +-- "since_id":0, +-- "refresh_url":"?since_id=30159761706061824&q=haskell", +-- "next_page":"?page=2&max_id=30159761706061824&rpp=1&q=haskell", +-- "results_per_page":1, +-- "page":1, +-- "completed_in":1.2606e-2, +-- "since_id_str":"0", +-- "max_id_str":"30159761706061824", +-- "query":"haskell" +-- } +-- @ +-- +prettyValue :: Value -> B.Builder () +prettyValue = prettyValue' 4 0 + + +-- | Encode a 'Value' with indentation and linefeed. +prettyValue' :: Int -- ^ indentation per level + -> Int -- ^ initial indentation + -> Value -> B.Builder () +{-# INLINABLE prettyValue' #-} +prettyValue' c !ind (Object kvs) = objectPretty c ind kvs +prettyValue' c !ind (Array vs) = arrayPretty c ind vs +prettyValue' _ !ind (String t) = B.word8N ind SPACE >> string t +prettyValue' _ !ind (Number n) = B.word8N ind SPACE >> scientific n +prettyValue' _ !ind (Bool True) = B.word8N ind SPACE >> "true" +prettyValue' _ !ind (Bool False) = B.word8N ind SPACE >> "false" +prettyValue' _ !ind _ = B.word8N ind SPACE >> "null" + +arrayPretty :: Int -> Int -> V.Vector Value -> B.Builder () +{-# INLINE arrayPretty #-} +arrayPretty idpl ind vs + | V.null vs = B.word8N ind SPACE >> B.square (return ()) + | otherwise = do + B.word8N ind SPACE + B.encodePrim (SQUARE_LEFT, NEWLINE) + B.intercalateVec + (B.encodePrim (COMMA, NEWLINE)) + (prettyValue' idpl ind') + vs + B.word8 NEWLINE + B.word8N ind SPACE + B.word8 SQUARE_RIGHT + where + ind' = ind + idpl + +objectPretty :: Int -> Int -> V.Vector (T.Text, Value) -> B.Builder () +{-# INLINE objectPretty #-} +objectPretty idpl ind kvs + | V.null kvs = B.word8N ind SPACE >> B.curly (return ()) + | otherwise = do + B.word8N ind SPACE + B.encodePrim (CURLY_LEFT, NEWLINE) + B.intercalateVec + (B.encodePrim (COMMA, NEWLINE)) + (\ (k, v) -> do + B.word8N ind' SPACE + string k + B.colon + if isSimpleValue v + then prettyValue' idpl 0 v + else do + B.word8 NEWLINE + prettyValue' idpl ind' v) + kvs + B.word8 NEWLINE + B.word8N ind SPACE + B.word8 CURLY_RIGHT + where + ind' = ind + idpl + isSimpleValue v = case v of + (Object kvs') -> V.null kvs' + (Array vs) -> V.null vs + _ -> True 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 @@ -23,7 +23,7 @@ module Z.Data.JSON.Value ( -- * Value type - Value(..) + Value(..), key, nth -- * parse into JSON Value , parseValue , parseValue' @@ -34,24 +34,30 @@ , array , string , skipSpaces + -- * Convert to Scientific + , floatToScientific + , doubleToScientific ) where import Control.DeepSeq -import Data.Bits ((.&.)) +import Data.Bits ((.&.)) import Data.Functor -import Data.Scientific (Scientific, scientific) +import Data.Scientific (Scientific, scientific) import Data.Typeable +import Data.Int import Data.Word import GHC.Generics -import qualified Z.Data.Parser as P -import qualified Z.Data.Text.Base as T -import Z.Data.Text.Print (Print(..)) -import Z.Data.Vector.Base as V -import Z.Data.Vector.Extra as V +import qualified Z.Data.Parser as P +import qualified Z.Data.Builder.Numeric as B +import qualified Z.Data.Text.Base as T +import Z.Data.Text.Print (Print(..)) +import Z.Data.Vector.Base as V +import Z.Data.Vector.Extra as V +import Z.Data.Vector.Search as V import Z.Foreign -import System.IO.Unsafe (unsafeDupablePerformIO) -import Test.QuickCheck.Arbitrary (Arbitrary(..)) -import Test.QuickCheck.Gen (Gen(..), listOf) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.QuickCheck.Arbitrary (Arbitrary(..)) +import Test.QuickCheck.Gen (Gen(..), listOf) #define BACKSLASH 92 #define CLOSE_CURLY 125 @@ -127,6 +133,29 @@ shrink (Array vs) = V.unpack vs shrink _ = [] +-- | Lense for 'Array' element. +-- +-- 1. return `Null` if 'Value' is not an 'Array' or index not exist. +-- 2. Modify will have no effect if 'Value' is not an 'Array' or index not exist. +-- +nth :: Functor f => Int -> (Value -> f Value) -> Value -> f Value +{-# INLINABLE nth #-} +nth ix f (Array vs) | Just v <- vs `indexMaybe` ix = + fmap (\ x -> Array (V.unsafeModifyIndex vs ix (const x))) (f v) +nth _ f v = fmap (const v) (f Null) + +-- | Lense for 'Object' element +-- +-- 1. return `Null` if 'Value' is not an 'Object' or key not exist. +-- 2. Modify will have no effect if 'Value' is not an 'Object' or key not exist. +-- 4. On duplicated keys prefer the last one. +-- +key :: Functor f => T.Text -> (Value -> f Value) -> Value -> f Value +{-# INLINABLE key #-} +key k f (Object kvs) | (i, Just (_, v)) <- V.findR ((k ==) . fst) kvs = + fmap (\ x -> Object (V.unsafeModifyIndex kvs i (const (k, x)))) (f v) +key _ f v = fmap (const v) (f Null) + -- | Parse 'Value' without consuming trailing bytes. parseValue :: V.Bytes -> (V.Bytes, Either P.ParseError Value) {-# INLINE parseValue #-} @@ -258,3 +287,28 @@ foreign import ccall unsafe find_json_string_end :: MBA# Word32 -> BA# Word8 -> Int -> Int -> IO Int foreign import ccall unsafe decode_json_string :: MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int + +-------------------------------------------------------------------------------- + +-- | Convert IEEE float to scientific notition. +floatToScientific :: Float -> Scientific +{-# INLINE floatToScientific #-} +floatToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3_sp (-rf))) + | rf == 0 = 0 + | otherwise = fromFloatingDigits (B.grisu3_sp rf) + +-- | Convert IEEE double to scientific notition. +doubleToScientific :: Double -> Scientific +{-# INLINE doubleToScientific #-} +doubleToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3 (-rf))) + | rf == 0 = 0 + | otherwise = fromFloatingDigits (B.grisu3 rf) + +fromFloatingDigits :: ([Int], Int) -> Scientific +{-# INLINE fromFloatingDigits #-} +fromFloatingDigits (digits, e) = go digits 0 0 + where + -- There's no way a float or double has more digits a 'Int64' can't handle + go :: [Int] -> Int64 -> Int -> Scientific + go [] !c !n = scientific (fromIntegral c) (e - n) + go (d:ds) !c !n = go ds (c * 10 + fromIntegral d) (n + 1) diff --git a/Z/Data/Parser/Numeric.hs b/Z/Data/Parser/Numeric.hs --- a/Z/Data/Parser/Numeric.hs +++ b/Z/Data/Parser/Numeric.hs @@ -32,8 +32,6 @@ , hexLoop , decLoop , decLoopIntegerFast - , floatToScientific - , doubleToScientific ) where import Control.Applicative @@ -43,7 +41,6 @@ import qualified Data.Scientific as Sci import Data.Word import Z.Data.ASCII -import qualified Z.Data.Builder.Numeric as B import Z.Data.Parser.Base (Parser, ()) import qualified Z.Data.Parser.Base as P import qualified Z.Data.Vector.Base as V @@ -441,26 +438,3 @@ Just ec | ec == LETTER_e || ec == LETTER_E -> P.skipWord8 *> int _ -> pure 0 pure $! Sci.scientific c (e' - e) - --------------------------------------------------------------------------------- - -floatToScientific :: Float -> Sci.Scientific -{-# INLINE floatToScientific #-} -floatToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3_sp (-rf))) - | rf == 0 = 0 - | otherwise = fromFloatingDigits (B.grisu3_sp rf) - -doubleToScientific :: Double -> Sci.Scientific -{-# INLINE doubleToScientific #-} -doubleToScientific rf | rf < 0 = -(fromFloatingDigits (B.grisu3 (-rf))) - | rf == 0 = 0 - | otherwise = fromFloatingDigits (B.grisu3 rf) - -fromFloatingDigits :: ([Int], Int) -> Sci.Scientific -{-# INLINE fromFloatingDigits #-} -fromFloatingDigits (digits, e) = go digits 0 0 - where - -- There's no way a float or double has more digits a 'Int64' can't handle - go :: [Int] -> Int64 -> Int -> Sci.Scientific - go [] !c !n = Sci.scientific (fromIntegral c) (e - n) - go (d:ds) !c !n = go ds (c * 10 + fromIntegral d) (n + 1) diff --git a/Z/Data/Text.hs b/Z/Data/Text.hs --- a/Z/Data/Text.hs +++ b/Z/Data/Text.hs @@ -42,6 +42,8 @@ , concat, concatMap -- ** Special folds , count, all, any + -- ** Text display width + , displayWidth -- * Slice manipulation , cons, snoc , uncons, unsnoc diff --git a/Z/Data/Text/Base.hs b/Z/Data/Text/Base.hs --- a/Z/Data/Text/Base.hs +++ b/Z/Data/Text/Base.hs @@ -37,6 +37,8 @@ , concat, concatMap -- ** Special folds , count, all, any + -- ** Text display width + , displayWidth -- ** normalization , NormalizationResult(..), NormalizeMode(..) , isNormalized, isNormalizedTo, normalize, normalizeTo @@ -126,6 +128,7 @@ import qualified Data.List as List import Data.Primitive.PrimArray import Data.Typeable +import Data.Int import Data.Word import Foreign.C.Types (CSize(..)) import GHC.Exts @@ -229,7 +232,6 @@ index t n = case t `indexMaybe` n of Nothing -> throw (IndexOutOfTextRange n callStack) Just x -> x - -- | /O(n)/ Get the nth codepoint from 'Text'. indexMaybe :: Text -> Int -> Maybe Char {-# INLINABLE indexMaybe #-} @@ -1088,3 +1090,25 @@ -- functions below will return error if the source ByteArray# is empty foreign import ccall utf8_iscategory :: ByteArray# -> Int# -> Int# -> Category -> Int + +-- | Get the display width of a piece of text. +-- +-- You shouldn't pass texts with control characters(<0x20, \\DEL), which are counted with -1 width. +-- +-- >>> displayWidth "你好世界！" +-- >>> 10 +-- >>> displayWidth "hello world!" +-- >>> 12 +-- +displayWidth :: Text -> Int +{-# INLINE displayWidth #-} +displayWidth (Text (V.PrimVector ba s l)) = go s 0 + where + !end = s + l + go !i !acc + | i >= end = acc + | otherwise = + let (# c, n #) = decodeChar ba i + in go (i+n) (acc + mk_wcwidth (fromIntegral (fromEnum c))) + +foreign import ccall unsafe "hs_wcwidth.c mk_wcwidth" mk_wcwidth :: Int32 -> Int diff --git a/Z/Data/Text/Print.hs b/Z/Data/Text/Print.hs --- a/Z/Data/Text/Print.hs +++ b/Z/Data/Text/Print.hs @@ -165,10 +165,11 @@ {-# INLINE gFieldToUTF8BuilderP #-} gFieldToUTF8BuilderP _ p (M1 x) = gToUTF8BuilderP p x -instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where - {-# INLINE gFieldToUTF8BuilderP #-} - gFieldToUTF8BuilderP _ _ m1@(M1 x) = - B.stringModifiedUTF8 (selName m1) >> " = " >> gToUTF8BuilderP 0 x +instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => + GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where + {-# INLINE gFieldToUTF8BuilderP #-} + gFieldToUTF8BuilderP _ _ m1@(M1 x) = + B.stringModifiedUTF8 (selName m1) >> " = " >> gToUTF8BuilderP 0 x instance GToText V1 where {-# INLINE gToUTF8BuilderP #-} diff --git a/Z/Data/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -63,6 +63,9 @@ Vec(IArray, toArr) , arrVec , indexMaybe, index, indexM + , modifyIndex, modifyIndexMaybe + , insertIndex, insertIndexMaybe + , deleteIndex, deleteIndexMaybe -- * Boxed and unboxed vector type , Vector , PrimVector diff --git a/Z/Data/Vector/Base.hs b/Z/Data/Vector/Base.hs --- a/Z/Data/Vector/Base.hs +++ b/Z/Data/Vector/Base.hs @@ -86,29 +86,31 @@ import Control.Monad import Control.Monad.ST import Data.Bits -import Data.Char (ord) -import qualified Data.Foldable as F -import Data.Hashable (Hashable(..)) -import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1) -import qualified Data.List as List +import Data.Char (ord) +import qualified Data.Foldable as F +import Data.Hashable (Hashable(..)) +import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Maybe -import qualified Data.CaseInsensitive as CI +import qualified Data.CaseInsensitive as CI import Data.Primitive import Data.Primitive.Ptr -import qualified Data.Traversable as T +import Data.Semigroup (Semigroup (..)) +import qualified Data.Traversable as T import Foreign.C import GHC.Exts import GHC.Stack import GHC.CString import GHC.Word -import Prelude hiding (concat, concatMap, +import Prelude hiding (concat, concatMap, elem, notElem, null, length, map, foldl, foldl1, foldr, foldr1, maximum, minimum, product, sum, all, any, replicate, traverse) -import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) -import Text.Read (Read(..)) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) +import Text.Read (Read(..)) +import System.IO.Unsafe (unsafeDupablePerformIO) import Z.Data.Array @@ -176,7 +178,7 @@ pattern Vec arr s l <- (toArr -> (arr,s,l)) where Vec arr s l = fromArr arr s l --- | /O(1)/ Index array element. +-- | /O(1)/ Index vector's element. -- -- Return 'Nothing' if index is out of bounds. -- @@ -247,6 +249,10 @@ instance Semigroup (Vector a) where {-# INLINE (<>) #-} (<>) = append + {-# INLINE sconcat #-} + sconcat (b:|bs) = concat (b:bs) + {-# INLINE stimes #-} + stimes = _cycleN instance Monoid (Vector a) where {-# INLINE mempty #-} @@ -459,6 +465,10 @@ instance Prim a => Semigroup (PrimVector a) where {-# INLINE (<>) #-} (<>) = append + {-# INLINE sconcat #-} + sconcat (b:|bs) = concat (b:bs) + {-# INLINE stimes #-} + stimes = _cycleN instance Prim a => Monoid (PrimVector a) where {-# INLINE mempty #-} @@ -1211,11 +1221,16 @@ -- | /O(n*m)/ 'cycleN' a vector n times. cycleN :: forall v a. Vec v a => Int -> v a -> v a {-# INLINE cycleN #-} -cycleN n (Vec arr s l) +cycleN = _cycleN + +-- | /O(n*m)/ 'cycleN''s polymorphic type version +_cycleN :: forall v a x. (Vec v a, Integral x) => x -> v a -> v a +{-# INLINE _cycleN #-} +_cycleN n (Vec arr s l) | l == 0 = empty | otherwise = create end (go 0) where - !end = n*l + !end = fromIntegral n * l go :: Int -> MArr (IArray v) s a -> ST s () go !i !marr | i >= end = return () | otherwise = copyArr marr i arr s l >> go (i+l) marr @@ -1397,3 +1412,4 @@ -- HsInt hs_memrchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n); foreign import ccall unsafe "hs_memrchr" c_memrchr :: ByteArray# -> Int -> Word8 -> Int -> Int + diff --git a/Z/Data/Vector/Extra.hs b/Z/Data/Vector/Extra.hs --- a/Z/Data/Vector/Extra.hs +++ b/Z/Data/Vector/Extra.hs @@ -49,22 +49,29 @@ , init , last , index, indexM + , modifyIndex, modifyIndexMaybe + , insertIndex, insertIndexMaybe + , deleteIndex, deleteIndexMaybe , unsafeHead , unsafeTail , unsafeInit , unsafeLast - , unsafeIndex, unsafeIndexM + , unsafeIndex, unsafeIndexM, unsafeModifyIndex, unsafeInsertIndex, unsafeDeleteIndex , unsafeTake , unsafeDrop ) where +import Control.Exception (assert) import Control.Monad.ST +import Data.Primitive.ByteArray import GHC.Stack import GHC.Word +import GHC.Exts import Z.Data.Array +import Z.Data.ASCII (isSpace) import Z.Data.Vector.Base import Z.Data.Vector.Search -import Prelude hiding (concat, concatMap, +import Prelude hiding (concat, concatMap, elem, notElem, null, length, map, foldl, foldl1, foldr, foldr1, maximum, minimum, product, sum, @@ -74,8 +81,8 @@ takeWhile, dropWhile, break, span, reverse, words, lines, unwords, unlines) -import qualified Data.List as List -import Control.Exception (assert) +import qualified Data.List as List +import System.IO.Unsafe (unsafeDupablePerformIO) -------------------------------------------------------------------------------- -- Slice @@ -477,7 +484,7 @@ if s' == end then [] else let !v = fromArr arr s' (end-s') in [v] - | isASCIISpace (indexArr arr i) = + | isSpace (indexArr arr i) = if s' == i then go (i+1) (i+1) else @@ -552,7 +559,8 @@ -- Lists. -- intersperse :: forall v a. Vec v a => a -> v a -> v a -{-# INLINE intersperse #-} +{-# INLINE[1] intersperse #-} +{-# RULES "intersperse/Bytes" intersperse = intersperseBytes #-} intersperse x v@(Vec arr s l) | l <= 1 = v | otherwise = create (2*l-1) (go s 0) where @@ -578,6 +586,18 @@ writeArr marr (j+1) x go (i+1) (j+2) marr +-- | /O(n)/ Special 'intersperse' for 'Bytes' using SIMD +intersperseBytes :: Word8 -> Bytes -> Bytes +{-# INLINE intersperseBytes #-} +intersperseBytes c v@(PrimVector (PrimArray ba#) offset l) + | l <= 1 = v + | otherwise = unsafeDupablePerformIO $ do + mba@(MutableByteArray mba#) <- newByteArray n + c_intersperse mba# ba# offset l c + (ByteArray ba'#) <- unsafeFreezeByteArray mba + return (PrimVector (PrimArray ba'#) 0 n) + where n = 2*l-1 + -- | /O(n)/ The 'intercalate' function takes a vector and a list of -- vectors and concatenates the list after interspersing the first -- argument between each element of the list. @@ -727,9 +747,6 @@ | r > max' = max' | otherwise = r -isASCIISpace :: Word8 -> Bool -{-# INLINE isASCIISpace #-} -isASCIISpace w = w == 32 || w - 0x9 <= 4 || w == 0xa0 -------------------------------------------------------------------------------- @@ -785,6 +802,61 @@ indexM (Vec arr s l) i | i < 0 || i >= l = errorOutRange i | otherwise = arr `indexArrM` (s + i) +-- | /O(n)/ Modify vector's element under given index. +-- +-- Throw 'IndexOutOfVectorRange' if index outside of the vector. +-- +modifyIndex :: (Vec v a, HasCallStack) => v a -> Int -> (a -> a) -> v a +{-# INLINE modifyIndex #-} +modifyIndex v@(Vec _ _ l) i f | i < 0 || i >= l = errorOutRange i + | otherwise = unsafeModifyIndex v i f + +-- | /O(n)/ Modify vector's element under given index. +-- +-- Return original vector if index outside of the vector. +-- +modifyIndexMaybe :: (Vec v a, HasCallStack) => v a -> Int -> (a -> a) -> v a +{-# INLINE modifyIndexMaybe #-} +modifyIndexMaybe v@(Vec _ _ l) i f | i < 0 || i >= l = v + | otherwise = unsafeModifyIndex v i f + +-- | /O(n)/ insert element to vector under given index. +-- +-- Throw 'IndexOutOfVectorRange' if index outside of the vector. +-- +insertIndex :: (Vec v a, HasCallStack) => v a -> Int -> a -> v a +{-# INLINE insertIndex #-} +insertIndex v@(Vec _ _ l) i x | i < 0 || i > l = errorOutRange i + | otherwise = unsafeInsertIndex v i x + +-- | /O(n)/ insert element to vector under given index. +-- +-- Return original vector if index outside of the vector. +-- +insertIndexMaybe :: (Vec v a, HasCallStack) => v a -> Int -> a -> v a +{-# INLINE insertIndexMaybe #-} +insertIndexMaybe v@(Vec _ _ l) i x | i < 0 || i > l = v + | otherwise = unsafeInsertIndex v i x + +-- | /O(n)/ Delete vector's element under given index. +-- +-- Throw 'IndexOutOfVectorRange' if index outside of the vector. +-- +deleteIndex :: (Vec v a, HasCallStack) => v a -> Int -> v a +{-# INLINE deleteIndex #-} +deleteIndex v@(Vec _ _ l) i | i < 0 || i >= l = errorOutRange i + | otherwise = unsafeDeleteIndex v i + +-- | /O(n)/ Delete vector's element under given index. +-- +-- Return original vector if index outside of the vector. +-- +deleteIndexMaybe :: (Vec v a, HasCallStack) => v a -> Int -> v a +{-# INLINE deleteIndexMaybe #-} +deleteIndexMaybe v@(Vec _ _ l) i | i < 0 || i >= l = v + | otherwise = unsafeDeleteIndex v i + + -- | /O(1)/ Extract the first element of a vector. -- -- Make sure vector is non-empty, otherwise segmentation fault await! @@ -827,6 +899,27 @@ {-# INLINE unsafeIndexM #-} unsafeIndexM (Vec arr s _) i = indexArrM arr (s + i) +-- | /O(n)/ Modify vector's element under given index. +-- +-- Make sure index is in bound, otherwise segmentation fault await! +unsafeModifyIndex :: (Vec v a, HasCallStack) => v a -> Int -> (a -> a) -> v a +{-# INLINE unsafeModifyIndex #-} +unsafeModifyIndex (Vec arr s l) i f = Vec (modifyIndexArr arr s l i f) 0 l + +-- | /O(n)/ Insert element to vector under given index. +-- +-- Make sure index is in bound, otherwise segmentation fault await! +unsafeInsertIndex :: (Vec v a, HasCallStack) => v a -> Int -> a -> v a +{-# INLINE unsafeInsertIndex #-} +unsafeInsertIndex (Vec arr s l) i x = Vec (insertIndexArr arr s l i x) 0 (l+1) + +-- | /O(n)/ Delete vector's element under given index. +-- +-- Make sure index is in bound, otherwise segmentation fault await! +unsafeDeleteIndex :: (Vec v a, HasCallStack) => v a -> Int -> v a +{-# INLINE unsafeDeleteIndex #-} +unsafeDeleteIndex (Vec arr s l) i = Vec (deleteIndexArr arr s l i) 0 (l-1) + -- | /O(1)/ 'take' @n@, applied to a vector @xs@, returns the prefix -- of @xs@ of length @n@. -- @@ -842,3 +935,8 @@ unsafeDrop :: Vec v a => Int -> v a -> v a {-# INLINE unsafeDrop #-} unsafeDrop n (Vec arr s l) = assert (0 <= n && n <= l) (fromArr arr (s+n) (l-n)) + +-------------------------------------------------------------------------------- + +foreign import ccall unsafe "bytes.h hs_intersperse" c_intersperse :: + MutableByteArray# RealWorld -> ByteArray# -> Int -> Int -> Word8 -> IO () diff --git a/Z/Data/Vector/FlatIntMap.hs b/Z/Data/Vector/FlatIntMap.hs --- a/Z/Data/Vector/FlatIntMap.hs +++ b/Z/Data/Vector/FlatIntMap.hs @@ -26,8 +26,8 @@ , merge, mergeWithKey' -- * fold and traverse , foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', traverseWithKey - -- * binary & linear search on vectors - , linearSearch, linearSearchR, binarySearch + -- * binary search on vectors + , binarySearch ) where import Control.DeepSeq @@ -39,6 +39,7 @@ import qualified Data.Monoid as Monoid import qualified Data.Primitive.SmallArray as A import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V import qualified Z.Data.Vector.Sort as V import qualified Z.Data.Text.Print as T import Data.Function (on) @@ -193,45 +194,33 @@ -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Int -> v -> FlatIntMap v -> FlatIntMap v {-# INLINE insert #-} -insert k v (FlatIntMap vec@(V.Vector arr s l)) = +insert k v (FlatIntMap vec) = case binarySearch vec k of - Left i -> FlatIntMap (V.create (l+1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - A.writeSmallArray marr i (V.IPair k v) - when (i FlatIntMap (V.Vector (runST (do - let arr' = A.cloneSmallArray arr s l - marr <- A.unsafeThawSmallArray arr' - A.writeSmallArray marr i (V.IPair k v) - A.unsafeFreezeSmallArray marr)) 0 l) + Left i -> FlatIntMap (V.unsafeInsertIndex vec i (V.IPair k v)) + Right i -> FlatIntMap (V.unsafeModifyIndex vec i (const (V.IPair k v))) -- | /O(N)/ Delete a key value pair by key. delete :: Int -> FlatIntMap v -> FlatIntMap v {-# INLINE delete #-} -delete k m@(FlatIntMap vec@(V.Vector arr s l)) = +delete k m@(FlatIntMap vec) = case binarySearch vec k of Left _ -> m - Right i -> FlatIntMap $ V.create (l-1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - let i' = i+1 - when (i' FlatIntMap (V.unsafeDeleteIndex vec i) -- | /O(N)/ Modify a value by key. -- -- The value is evaluated to WHNF before writing into map. adjust' :: (v -> v) -> Int -> FlatIntMap v -> FlatIntMap v {-# INLINE adjust' #-} -adjust' f k m@(FlatIntMap vec@(V.Vector arr s l)) = +adjust' f k m@(FlatIntMap vec) = case binarySearch vec k of Left _ -> m - Right i -> FlatIntMap $ V.create l (\ marr -> do - A.copySmallArray marr 0 arr s l - let !v' = f (V.isnd (A.indexSmallArray arr (i+s))) - A.writeSmallArray marr i (V.IPair k v')) + Right i -> FlatIntMap . V.unsafeModifyIndex vec i $ + \ (V.IPair k' v) -> let !v' = f v in V.IPair k' v' -- | /O(n+m)/ Merge two 'FlatIntMap', prefer right value on key duplication. merge :: forall v. FlatIntMap v -> FlatIntMap v -> FlatIntMap v -{-# INLINE merge #-} +{-# INLINABLE merge #-} merge fmL@(FlatIntMap (V.Vector arrL sL lL)) fmR@(FlatIntMap (V.Vector arrR sR lR)) | null fmL = fmR | null fmR = fmL @@ -355,28 +344,3 @@ in case k' `compare` k of LT -> go s (mid-1) GT -> go (mid+1) e _ -> Right mid - --------------------------------------------------------------------------------- - --- | linear scan search from left to right, return the first one if exist. -linearSearch :: V.Vector (V.IPair v) -> Int -> Maybe v -{-# INLINABLE linearSearch #-} -linearSearch (V.Vector arr s l) !k' = go s - where - !end = s + l - go !i - | i >= end = Nothing - | otherwise = - let V.IPair k v = arr `A.indexSmallArray` i - in if k' == k then Just v else go (i+1) - --- | linear scan search from right to left, return the first one if exist. -linearSearchR :: V.Vector (V.IPair v) -> Int -> Maybe v -{-# INLINABLE linearSearchR #-} -linearSearchR (V.Vector arr s l) !k' = go (s+l-1) - where - go !i - | i < s = Nothing - | otherwise = - let V.IPair k v = arr `A.indexSmallArray` i - in if k' == k then Just v else go (i-1) diff --git a/Z/Data/Vector/FlatIntSet.hs b/Z/Data/Vector/FlatIntSet.hs --- a/Z/Data/Vector/FlatIntSet.hs +++ b/Z/Data/Vector/FlatIntSet.hs @@ -34,6 +34,7 @@ import qualified Data.Monoid as Monoid import qualified Data.Primitive.PrimArray as A import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V import qualified Z.Data.Vector.Sort as V import qualified Z.Data.Text.Print as T import Data.Bits (unsafeShiftR) @@ -146,28 +147,22 @@ -- | /O(N)/ Insert new value into set. insert :: Int -> FlatIntSet -> FlatIntSet {-# INLINE insert #-} -insert v m@(FlatIntSet vec@(V.PrimVector arr s l)) = +insert v m@(FlatIntSet vec) = case binarySearch vec v of - Left i -> FlatIntSet (V.create (l+1) (\ marr -> do - when (i>0) $ A.copyPrimArray marr 0 arr s i - A.writePrimArray marr i v - when (i FlatIntSet (V.unsafeInsertIndex vec i v) Right _ -> m -- | /O(N)/ Delete a value. delete :: Int -> FlatIntSet -> FlatIntSet {-# INLINE delete #-} -delete v m@(FlatIntSet vec@(V.PrimVector arr s l)) = +delete v m@(FlatIntSet vec) = case binarySearch vec v of Left _ -> m - Right i -> FlatIntSet $ V.create (l-1) (\ marr -> do - when (i>0) $ A.copyPrimArray marr 0 arr s i - let i' = i+1 - when (i' FlatIntSet (V.unsafeDeleteIndex vec i) -- | /O(n+m)/ Merge two 'FlatIntSet', prefer right value on value duplication. merge :: FlatIntSet -> FlatIntSet -> FlatIntSet -{-# INLINE merge #-} +{-# INLINABLE merge #-} merge fmL@(FlatIntSet (V.PrimVector arrL sL lL)) fmR@(FlatIntSet (V.PrimVector arrR sR lR)) | null fmL = fmR | null fmR = fmL diff --git a/Z/Data/Vector/FlatMap.hs b/Z/Data/Vector/FlatMap.hs --- a/Z/Data/Vector/FlatMap.hs +++ b/Z/Data/Vector/FlatMap.hs @@ -26,8 +26,8 @@ , merge, mergeWithKey' -- * fold and traverse , foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', traverseWithKey - -- * search on vectors - , linearSearch, linearSearchR, binarySearch + -- * binary search on vectors + , binarySearch ) where import Control.DeepSeq @@ -38,8 +38,9 @@ import qualified Data.Traversable as Traversable import qualified Data.Semigroup as Semigroup import qualified Data.Monoid as Monoid -import qualified Z.Data.Vector.Base as V -import qualified Z.Data.Vector.Sort as V +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V +import qualified Z.Data.Vector.Sort as V import qualified Z.Data.Text.Print as T import Data.Function (on) import Data.Bits (unsafeShiftR) @@ -193,45 +194,33 @@ -- | /O(N)/ Insert new key value into map, replace old one if key exists. insert :: Ord k => k -> v -> FlatMap k v -> FlatMap k v {-# INLINE insert #-} -insert k v (FlatMap vec@(V.Vector arr s l)) = +insert k v (FlatMap vec) = case binarySearch vec k of - Left i -> FlatMap (V.create (l+1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - A.writeSmallArray marr i (k, v) - when (i FlatMap (V.Vector (runST (do - let arr' = A.cloneSmallArray arr s l - marr <- A.unsafeThawSmallArray arr' - A.writeSmallArray marr i (k, v) - A.unsafeFreezeSmallArray marr)) 0 l) + Left i -> FlatMap (V.unsafeInsertIndex vec i (k, v)) + Right i -> FlatMap (V.unsafeModifyIndex vec i (const (k, v))) -- | /O(N)/ Delete a key value pair by key. delete :: Ord k => k -> FlatMap k v -> FlatMap k v {-# INLINE delete #-} -delete k m@(FlatMap vec@(V.Vector arr s l)) = +delete k m@(FlatMap vec) = case binarySearch vec k of Left _ -> m - Right i -> FlatMap $ V.create (l-1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - let i' = i+1 - when (i' FlatMap (V.unsafeDeleteIndex vec i) -- | /O(N)/ Modify a value by key. -- -- The value is evaluated to WHNF before writing into map. adjust' :: Ord k => (v -> v) -> k -> FlatMap k v -> FlatMap k v {-# INLINE adjust' #-} -adjust' f k m@(FlatMap vec@(V.Vector arr s l)) = +adjust' f k m@(FlatMap vec) = case binarySearch vec k of Left _ -> m - Right i -> FlatMap $ V.create l (\ marr -> do - A.copySmallArray marr 0 arr s l - let !v' = f (snd (A.indexSmallArray arr (i+s))) - A.writeSmallArray marr i (k, v')) + Right i -> FlatMap . V.unsafeModifyIndex vec i $ + \ (k', v) -> let !v' = f v in (k', v') -- | /O(n+m)/ Merge two 'FlatMap', prefer right value on key duplication. merge :: forall k v. Ord k => FlatMap k v -> FlatMap k v -> FlatMap k v -{-# INLINE merge #-} +{-# INLINABLE merge #-} merge fmL@(FlatMap (V.Vector arrL sL lL)) fmR@(FlatMap (V.Vector arrR sR lR)) | null fmL = fmR | null fmR = fmL @@ -356,28 +345,3 @@ in case k' `compare` k of LT -> go i (mid-1) GT -> go (mid+1) j _ -> Right mid - --------------------------------------------------------------------------------- - --- | linear scan search from left to right, return the first one if exist. -linearSearch :: Ord k => V.Vector (k, v) -> k -> Maybe v -{-# INLINABLE linearSearch #-} -linearSearch (V.Vector arr s l) !k' = go s - where - !end = s + l - go !i - | i >= end = Nothing - | otherwise = - let (k, v) = arr `A.indexSmallArray` i - in if k' == k then Just v else go (i+1) - --- | linear scan search from right to left, return the first one if exist. -linearSearchR :: Ord k => V.Vector (k, v) -> k -> Maybe v -{-# INLINABLE linearSearchR #-} -linearSearchR (V.Vector arr s l) !k' = go (s+l-1) - where - go !i - | i < s = Nothing - | otherwise = - let (k, v) = arr `A.indexSmallArray` i - in if k' == k then Just v else go (i-1) diff --git a/Z/Data/Vector/FlatSet.hs b/Z/Data/Vector/FlatSet.hs --- a/Z/Data/Vector/FlatSet.hs +++ b/Z/Data/Vector/FlatSet.hs @@ -34,6 +34,7 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Monoid as Monoid import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V import qualified Z.Data.Vector.Sort as V import qualified Z.Data.Text.Print as T import Data.Bits (unsafeShiftR) @@ -142,32 +143,25 @@ {-# INLINE elem #-} elem v (FlatSet vec) = case binarySearch vec v of Left _ -> False _ -> True - -- | /O(N)/ Insert new value into set. insert :: Ord v => v -> FlatSet v -> FlatSet v {-# INLINE insert #-} -insert v m@(FlatSet vec@(V.Vector arr s l)) = +insert v m@(FlatSet vec) = case binarySearch vec v of - Left i -> FlatSet (V.create (l+1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - A.writeSmallArray marr i v - when (i FlatSet (V.unsafeInsertIndex vec i v) Right _ -> m -- | /O(N)/ Delete a value from set. delete :: Ord v => v -> FlatSet v -> FlatSet v {-# INLINE delete #-} -delete v m@(FlatSet vec@(V.Vector arr s l)) = +delete v m@(FlatSet vec) = case binarySearch vec v of Left _ -> m - Right i -> FlatSet $ V.create (l-1) (\ marr -> do - when (i>0) $ A.copySmallArray marr 0 arr s i - let i' = i+1 - when (i' FlatSet (V.unsafeDeleteIndex vec i) -- | /O(n+m)/ Merge two 'FlatSet', prefer right value on value duplication. merge :: forall v . Ord v => FlatSet v -> FlatSet v -> FlatSet v -{-# INLINE merge #-} +{-# INLINABLE merge #-} merge fmL@(FlatSet (V.Vector arrL sL lL)) fmR@(FlatSet (V.Vector arrR sR lR)) | null fmL = fmR | null fmR = fmL diff --git a/cbits/bytes.c b/cbits/bytes.c --- a/cbits/bytes.c +++ b/cbits/bytes.c @@ -1,6 +1,7 @@ /* Copyright (c) 2017-2019 Dong Han Copyright Johan Tibell 2011, Dong Han 2019 +Copyright Dmitry Ivanov 2020 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -32,6 +33,11 @@ #include #endif +#if defined(__x86_64__) +#include +#include +#endif + HsInt hs_memchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n) { a += aoff; uint8_t *p = memchr(a, b, (size_t)n); @@ -267,4 +273,37 @@ #else return (HsInt)tb64xdec(input+off, (size_t)len, output); #endif +} + +/* duplicate a string, interspersing the character through the elements + of the duplicated string + from https://github.com/haskell/bytestring/pull/310/files +*/ +void hs_intersperse(unsigned char *q, + unsigned char *p, HsInt p_offset, + HsInt n, + unsigned char c) { +#if defined(__x86_64__) + { + const __m128i separator = _mm_set1_epi8(c); + p += p_offset; + const unsigned char *const p_begin = p; + const unsigned char *const p_end = p_begin + n - 9; + while (p < p_end) { + const __m128i eight_src_bytes = _mm_loadl_epi64((__m128i *)p); + const __m128i sixteen_dst_bytes = _mm_unpacklo_epi8(eight_src_bytes, separator); + _mm_storeu_si128((__m128i *)q, sixteen_dst_bytes); + p += 8; + q += 16; + } + n -= p - p_begin; + } +#endif + while (n > 1) { + *q++ = *p++; + *q++ = c; + n--; + } + if (n == 1) + *q = *p; } diff --git a/cbits/text.c b/cbits/text.c --- a/cbits/text.c +++ b/cbits/text.c @@ -344,7 +344,7 @@ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,6, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, diff --git a/cbits/text_width.c b/cbits/text_width.c new file mode 100644 --- /dev/null +++ b/cbits/text_width.c @@ -0,0 +1,218 @@ +/* + * This is an implementation of wcwidth() and wcswidth() (defined in + * IEEE Std 1002.1-2001) for Unicode. + * + * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html + * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html + * + * In fixed-width output devices, Latin characters all occupy a single + * "cell" position of equal width, whereas ideographic CJK characters + * occupy two such cells. Interoperability between terminal-line + * applications and (teletype-style) character terminals using the + * UTF-8 encoding requires agreement on which character should advance + * the cursor by how many cell positions. No established formal + * standards exist at present on which Unicode character shall occupy + * how many cell positions on character terminals. These routines are + * a first attempt of defining such behavior based on simple rules + * applied to data provided by the Unicode Consortium. + * + * For some graphical characters, the Unicode standard explicitly + * defines a character-cell width via the definition of the East Asian + * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes. + * In all these cases, there is no ambiguity about which width a + * terminal shall use. For characters in the East Asian Ambiguous (A) + * class, the width choice depends purely on a preference of backward + * compatibility with either historic CJK or Western practice. + * Choosing single-width for these characters is easy to justify as + * the appropriate long-term solution, as the CJK practice of + * displaying these characters as double-width comes from historic + * implementation simplicity (8-bit encoded characters were displayed + * single-width and 16-bit ones double-width, even for Greek, + * Cyrillic, etc.) and not any typographic considerations. + * + * Much less clear is the choice of width for the Not East Asian + * (Neutral) class. Existing practice does not dictate a width for any + * of these characters. It would nevertheless make sense + * typographically to allocate two character cells to characters such + * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be + * represented adequately with a single-width glyph. The following + * routines at present merely assign a single-cell width to all + * neutral characters, in the interest of simplicity. This is not + * entirely satisfactory and should be reconsidered before + * establishing a formal standard in this area. At the moment, the + * decision which Not East Asian (Neutral) characters should be + * represented by double-width glyphs cannot yet be answered by + * applying a simple rule from the Unicode database content. Setting + * up a proper standard for the behavior of UTF-8 character terminals + * will require a careful analysis not only of each Unicode character, + * but also of each presentation form, something the author of these + * routines has avoided to do so far. + * + * http://www.unicode.org/unicode/reports/tr11/ + * + * Markus Kuhn -- 2007-05-26 (Unicode 5.0) + * + * Permission to use, copy, modify, and distribute this software + * for any purpose and without fee is hereby granted. The author + * disclaims all warranties with regard to this software. + * + * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c + */ + +#include + +struct interval { + int32_t first; + int32_t last; +}; + +/* auxiliary function for binary search in interval table */ +static HsInt bisearch(int32_t ucs, const struct interval *table, HsInt max) { + HsInt min = 0; + HsInt mid; + + if (ucs < table[0].first || ucs > table[max].last) + return 0; + while (max >= min) { + mid = (min + max) / 2; + if (ucs > table[mid].last) + min = mid + 1; + else if (ucs < table[mid].first) + max = mid - 1; + else + return 1; + } + + return 0; +} + + +/* The following two functions define the column width of an ISO 10646 + * character as follows: + * + * - The null character (U+0000) has a column width of 0. + * + * - Other C0/C1 control characters and DEL will lead to a return + * value of -1. + * + * - Non-spacing and enclosing combining characters (general + * category code Mn or Me in the Unicode database) have a + * column width of 0. + * + * - SOFT HYPHEN (U+00AD) has a column width of 1. + * + * - Other format characters (general category code Cf in the Unicode + * database) and ZERO WIDTH SPACE (U+200B) have a column width of 0. + * + * - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF) + * have a column width of 0. + * + * - Spacing characters in the East Asian Wide (W) or East Asian + * Full-width (F) category as defined in Unicode Technical + * Report #11 have a column width of 2. + * + * - All remaining characters (including all printable + * ISO 8859-1 and WGL4 characters, Unicode control characters, + * etc.) have a column width of 1. + * + * This implementation assumes that int32_t characters are encoded + * in ISO 10646. + */ + +HsInt mk_wcwidth(int32_t ucs) +{ + /* sorted list of non-overlapping intervals of non-spacing characters */ + /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */ + static const struct interval combining[] = { + { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 }, + { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 }, + { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 }, + { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 }, + { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED }, + { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A }, + { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 }, + { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D }, + { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 }, + { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD }, + { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C }, + { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D }, + { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC }, + { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD }, + { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C }, + { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D }, + { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 }, + { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 }, + { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC }, + { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD }, + { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D }, + { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 }, + { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E }, + { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC }, + { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 }, + { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E }, + { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 }, + { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 }, + { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 }, + { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F }, + { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 }, + { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD }, + { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD }, + { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 }, + { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B }, + { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 }, + { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 }, + { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF }, + { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 }, + { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F }, + { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B }, + { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F }, + { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB }, + { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F }, + { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 }, + { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD }, + { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F }, + { 0xE0100, 0xE01EF } + }; + + /* test for 8-bit control characters */ + if (ucs == 0) + return 0; + if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0)) + return -1; + + /* binary search in table of non-spacing characters */ + if (bisearch(ucs, combining, + sizeof(combining) / sizeof(struct interval) - 1)) + return 0; + + /* if we arrive here, ucs is not a combining or C0/C1 control character */ + + return 1 + + (ucs >= 0x1100 && + (ucs <= 0x115f || /* Hangul Jamo init. consonants */ + ucs == 0x2329 || ucs == 0x232a || + (ucs >= 0x2e80 && ucs <= 0xa4cf && + ucs != 0x303f) || /* CJK ... Yi */ + (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */ + (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */ + (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */ + (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */ + (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */ + (ucs >= 0xffe0 && ucs <= 0xffe6) || + (ucs >= 0x20000 && ucs <= 0x2fffd) || + (ucs >= 0x30000 && ucs <= 0x3fffd))); +} + +HsInt mk_wcswidth(const int32_t *pwcs, HsInt n) +{ + HsInt w, width = 0; + + for (;*pwcs && n-- > 0; pwcs++) + if ((w = mk_wcwidth(*pwcs)) < 0) + return -1; + else + width += w; + + return width; +} + diff --git a/include/bytes.h b/include/bytes.h --- a/include/bytes.h +++ b/include/bytes.h @@ -44,3 +44,4 @@ void hs_base64_encode(uint8_t* output, HsInt output_off, const uint8_t* input, HsInt input_off, HsInt input_length); HsInt hs_base64_decode(uint8_t* output, const uint8_t* input, HsInt input_off, HsInt input_length); +void hs_intersperse(unsigned char *q, unsigned char *p, HsInt p_offset, HsInt n, unsigned char c); diff --git a/test/Z/Data/JSON/ValueSpec.hs b/test/Z/Data/JSON/ValueSpec.hs --- a/test/Z/Data/JSON/ValueSpec.hs +++ b/test/Z/Data/JSON/ValueSpec.hs @@ -13,6 +13,7 @@ import Test.QuickCheck.Property import Test.Hspec import Test.Hspec.QuickCheck +import qualified Data.Scientific as Sci import qualified Z.Data.JSON.Value as JSON import qualified Z.Data.JSON.Builder as JSONB @@ -21,3 +22,9 @@ spec = describe "JSON" $ do -- large size will generate too huge JSON document prop "value roundtrip" $ \ v -> Right v === JSON.parseValue' (B.build (JSONB.value v)) + + describe "floatToScientific, doubleToScientific === fromFloatDigits" $ do + prop "floatToScientific == fromFloatDigits" $ \ i -> + JSON.floatToScientific i === Sci.fromFloatDigits i + prop "floatToScientific === fromFloatDigits" $ \ i -> + JSON.doubleToScientific i === Sci.fromFloatDigits i diff --git a/test/Z/Data/Parser/NumericSpec.hs b/test/Z/Data/Parser/NumericSpec.hs --- a/test/Z/Data/Parser/NumericSpec.hs +++ b/test/Z/Data/Parser/NumericSpec.hs @@ -14,7 +14,6 @@ import qualified Z.Data.Builder.Base as B import qualified Z.Data.Text as T import qualified Z.Data.Vector.Base as V -import qualified Data.Scientific as Sci import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Property @@ -93,9 +92,3 @@ P.parse' P.float (B.build (B.float i)) === Right (i :: Float) prop "double roundtrip" $ \ i -> P.parse' P.double (B.build (B.double i)) === Right (i :: Double) - - describe "floatToScientific, doubleToScientific === fromFloatDigits" $ do - prop "floatToScientific == fromFloatDigits" $ \ i -> - P.floatToScientific i === Sci.fromFloatDigits i - prop "floatToScientific === fromFloatDigits" $ \ i -> - P.doubleToScientific i === Sci.fromFloatDigits i