Z-Data 0.6.0.0 → 0.6.1.0

raw patch · 31 files changed

+1127/−506 lines, 31 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• README.md +7/−4
• Z-Data.cabal +5/−3
• Z/Data/Array.hs +65/−1
• Z/Data/Array/Checked.hs +81/−31
• Z/Data/Array/UnliftedArray.hs +11/−6
• Z/Data/Builder.hs +2/−1
• Z/Data/Builder/Base.hs +11/−1
• Z/Data/Builder/Numeric.hs +2/−2
• Z/Data/Generics/Utils.hs +1/−0
• Z/Data/JSON.hs +267/−2
• Z/Data/JSON/Base.hs +14/−259
• Z/Data/JSON/Builder.hs +109/−2
• Z/Data/JSON/Value.hs +65/−11
• Z/Data/Parser/Numeric.hs +0/−26
• Z/Data/Text.hs +2/−0
• Z/Data/Text/Base.hs +25/−1
• Z/Data/Text/Print.hs +5/−4
• Z/Data/Vector.hs +3/−0
• Z/Data/Vector/Base.hs +30/−14
• Z/Data/Vector/Extra.hs +107/−9
• Z/Data/Vector/FlatIntMap.hs +12/−48
• Z/Data/Vector/FlatIntSet.hs +6/−11
• Z/Data/Vector/FlatMap.hs +14/−50
• Z/Data/Vector/FlatSet.hs +6/−12
• cbits/bytes.c +39/−0
• cbits/text.c +1/−1
• cbits/text_width.c +218/−0
• include/bytes.h +1/−0
• test/Z/Data/JSON/ValueSpec.hs +7/−0
• test/Z/Data/Parser/NumericSpec.hs +0/−7

@@ -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`.

@@ -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

@@ -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

@@ -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<l) $ copyArr marr (i+1) arr (i+s) (l-i)+    unsafeFreezeArr marr++-- | Delete an immutable array's element at given index to produce a new array.+deleteIndexArr :: Arr arr a+               => 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'<l) $ copyArr marr i arr (i'+s) (l-i')+    unsafeFreezeArr marr

@@ -15,7 +15,9 @@ -} module Z.Data.Array.Checked   ( -- * Arr typeclass re-export-    A.Arr+    Arr, MArr+  , A.singletonArr, A.doubletonArr+  , modifyIndexArr, insertIndexArr, deleteIndexArr   , RealWorld   -- * Boxed array type   , A.Array(..)@@ -73,9 +75,12 @@   ) where  import           Control.Exception       (ArrayException (..), throw)+import           Control.Monad import           Control.Monad.Primitive+import           Control.Monad.ST import           Data.Primitive.Types import           GHC.Stack+import           Z.Data.Array          (Arr, MArr) import qualified Z.Data.Array          as A  check :: HasCallStack => 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<A.sizeofArr arr)     (A.indexArr arr i) {-# INLINE indexArr #-} -indexArr' :: (A.Arr arr a, HasCallStack)+indexArr' :: (Arr arr a, HasCallStack)           => arr a -> Int -> (# a #) indexArr' arr i =     if (i>=0 && i<A.sizeofArr arr)@@ -135,15 +140,15 @@     else throw (IndexOutOfBounds $ show callStack) {-# INLINE indexArr' #-} -indexArrM :: (A.Arr arr a, Monad m, HasCallStack)+indexArrM :: (Arr arr a, Monad m, HasCallStack)           => arr a -> Int -> m a indexArrM arr i = check     (i>=0 && i<A.sizeofArr arr)     (A.indexArrM arr i) {-# INLINE indexArrM #-} -freezeArr :: (A.Arr arr a, PrimMonad m, PrimState m ~ s, HasCallStack)-          => 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<l) $ copyArr marr (i+1) arr (i+s) (l-i)+    A.unsafeFreezeArr marr++-- | Drop an immutable array's element at given index to produce a new array.+deleteIndexArr :: Arr arr a+               => 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'<l) $ copyArr marr i arr (i'+s) (l-i')+    A.unsafeFreezeArr marr

@@ -43,6 +43,7 @@ import GHC.MVar (MVar(..)) import GHC.IORef (IORef(..)) import GHC.STRef (STRef(..))+import GHC.Conc (TVar(..)) import GHC.Exts import GHC.IO.Unsafe @@ -98,9 +99,6 @@         (# s1, x #) -> (# 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# #-}

@@ -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(..)

@@ -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'. --

@@ -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

@@ -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)))

@@ -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)

@@ -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)

@@ -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":"&lt;a href=&quot;http://twitter.com/&quot;&gt;web&lt;/a&gt;"+--         }+--     ],+--     "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

@@ -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)

@@ -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)

@@ -42,6 +42,8 @@   , concat, concatMap     -- ** Special folds   , count, all, any+    -- ** Text display width+  , displayWidth   -- * Slice manipulation   , cons, snoc   , uncons, unsnoc

@@ -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

@@ -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 #-}

@@ -63,6 +63,9 @@     Vec(IArray, toArr)   , arrVec   , indexMaybe, index, indexM+  , modifyIndex, modifyIndexMaybe+  , insertIndex, insertIndexMaybe+  , deleteIndex, deleteIndexMaybe   -- * Boxed and unboxed vector type   , Vector   , PrimVector

@@ -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+

@@ -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 ()

@@ -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<l) $ A.copySmallArray marr (i+1) arr (i+s) (l-i)))-        Right 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'<l) $ A.copySmallArray marr i arr (i'+s) (l-i'))+        Right 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)

@@ -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<l) $ A.copyPrimArray marr (i+1) arr (i+s) (l-i)))+        Left 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'<l) $ A.copyPrimArray marr i arr (i'+s) (l-i'))+        Right 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

@@ -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<l) $ A.copySmallArray marr (i+1) arr (i+s) (l-i)))-        Right 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'<l) $ A.copySmallArray marr i arr (i'+s) (l-i'))+        Right 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)

@@ -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<l) $ A.copySmallArray marr (i+1) arr (i+s) (l-i)))+        Left 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'<l) $ A.copySmallArray marr i arr (i'+s) (l-i'))+        Right 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

@@ -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 <turbob64avx2.c> #endif +#if defined(__x86_64__)+#include <emmintrin.h>+#include <xmmintrin.h>+#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; }

@@ -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,

@@ -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 <HsFFI.h>++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;+}+

@@ -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);

@@ -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

@@ -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