diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for Z-Data +## 0.1.6.0 -- 2020-10-09 + +* Rename `ToText` to `ShowT`, `toText` to `showT`, add FFI types instances. +* Change `Text` 's `Show` and `ShowT` escaping rules to reuse JSON escaping, remove `Read` instance. +* Add `ShowT` instances to `CBytes` and FFI types. + ## 0.1.5.0 -- 2020-10-02 * Rework `CBytes` type to use unpinned byte array, add `withCBytesUnsafe`, `allocCBytesUnsafe`. diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.1.5.0 +version: 0.1.6.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -84,9 +84,9 @@ Z.Data.Text.Base Z.Data.Text.Extra Z.Data.Text.Search + Z.Data.Text.ShowT Z.Data.Text.UTF8Codec Z.Data.Text.UTF8Rewind - Z.Data.Text.Builder Z.Data.Builder Z.Data.Builder.Base @@ -168,6 +168,40 @@ -Wno-unticked-promoted-constructors -Wno-incomplete-patterns -- ploymorphic pattern synonym messed exhaustiveness checker + default-extensions: BangPatterns + CApiFFI + ConstraintKinds + CPP + DerivingStrategies + DeriveGeneric + DeriveAnyClass + DefaultSignatures + DataKinds + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + KindSignatures + MagicHash + MultiParamTypeClasses + PartialTypeSignatures + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TypeApplications + TypeFamilyDependencies + TypeFamilies + TypeOperators + TupleSections + UnboxedTuples + UnliftedFFITypes + ViewPatterns test-suite Z-Data-Test type: exitcode-stdio-1.0 @@ -185,7 +219,7 @@ Z.Data.Parser.NumericSpec Z.Data.Array.UnalignedSpec Z.Data.Text.BaseSpec - Z.Data.Text.BuilderSpec + Z.Data.Text.ShowTSpec Z.Data.Text.ExtraSpec Z.Data.Text.SearchSpec Z.Data.Vector.BaseSpec diff --git a/Z/Data/Array.hs b/Z/Data/Array.hs --- a/Z/Data/Array.hs +++ b/Z/Data/Array.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} - - {-| Module : Z.Data.Array Description : Fast boxed and unboxed arrays diff --git a/Z/Data/Array/Cast.hs b/Z/Data/Array/Cast.hs --- a/Z/Data/Array/Cast.hs +++ b/Z/Data/Array/Cast.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} - {-| Module : Z.Data.Array.Cast Description : Primitive casting diff --git a/Z/Data/Array/Checked.hs b/Z/Data/Array/Checked.hs --- a/Z/Data/Array/Checked.hs +++ b/Z/Data/Array/Checked.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - {-| Module : Z.Data.Array.Checked Description : Bounded checked boxed and unboxed arrays diff --git a/Z/Data/Array/QQ.hs b/Z/Data/Array/QQ.hs --- a/Z/Data/Array/QQ.hs +++ b/Z/Data/Array/QQ.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - - {-| Module : Z.Data.Array.QQ Description : Extra stuff for PrimArray related literals diff --git a/Z/Data/Array/Unaligned.hs b/Z/Data/Array/Unaligned.hs --- a/Z/Data/Array/Unaligned.hs +++ b/Z/Data/Array/Unaligned.hs @@ -1,14 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} - {-| Module : Z.Data.Array.Unaligned Description : unaligned access for primitive arrays @@ -895,29 +885,29 @@ -------------------------------------------------------------------------------- -- Prim instances for newtypes in Foreign.C.Types -deriving instance Unaligned CChar -deriving instance Unaligned CSChar -deriving instance Unaligned CUChar -deriving instance Unaligned CShort -deriving instance Unaligned CUShort -deriving instance Unaligned CInt -deriving instance Unaligned CUInt -deriving instance Unaligned CLong -deriving instance Unaligned CULong -deriving instance Unaligned CPtrdiff -deriving instance Unaligned CSize -deriving instance Unaligned CWchar -deriving instance Unaligned CSigAtomic -deriving instance Unaligned CLLong -deriving instance Unaligned CULLong -deriving instance Unaligned CBool -deriving instance Unaligned CIntPtr -deriving instance Unaligned CUIntPtr -deriving instance Unaligned CIntMax -deriving instance Unaligned CUIntMax -deriving instance Unaligned CClock -deriving instance Unaligned CTime -deriving instance Unaligned CUSeconds -deriving instance Unaligned CSUSeconds -deriving instance Unaligned CFloat -deriving instance Unaligned CDouble +deriving newtype instance Unaligned CChar +deriving newtype instance Unaligned CSChar +deriving newtype instance Unaligned CUChar +deriving newtype instance Unaligned CShort +deriving newtype instance Unaligned CUShort +deriving newtype instance Unaligned CInt +deriving newtype instance Unaligned CUInt +deriving newtype instance Unaligned CLong +deriving newtype instance Unaligned CULong +deriving newtype instance Unaligned CPtrdiff +deriving newtype instance Unaligned CSize +deriving newtype instance Unaligned CWchar +deriving newtype instance Unaligned CSigAtomic +deriving newtype instance Unaligned CLLong +deriving newtype instance Unaligned CULLong +deriving newtype instance Unaligned CBool +deriving newtype instance Unaligned CIntPtr +deriving newtype instance Unaligned CUIntPtr +deriving newtype instance Unaligned CIntMax +deriving newtype instance Unaligned CUIntMax +deriving newtype instance Unaligned CClock +deriving newtype instance Unaligned CTime +deriving newtype instance Unaligned CUSeconds +deriving newtype instance Unaligned CSUSeconds +deriving newtype instance Unaligned CFloat +deriving newtype instance Unaligned CDouble diff --git a/Z/Data/Array/UnliftedArray.hs b/Z/Data/Array/UnliftedArray.hs --- a/Z/Data/Array/UnliftedArray.hs +++ b/Z/Data/Array/UnliftedArray.hs @@ -1,37 +1,40 @@ -{-# language MagicHash #-} -{-# language UnboxedTuples #-} -{-# language TypeFamilies #-} -{-# language TypeApplications #-} -{-# language ScopedTypeVariables #-} +{- | +Module : Z.Data.Array.UnliftedArray +Description : unlifted primitve arrays +Copyright : (c) Dong Han, 2017-2020 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable --- GHC contains three general classes of value types: --- --- 1. Unboxed types: values are machine values made up of fixed numbers of bytes --- 2. Unlifted types: values are pointers, but strictly evaluated --- 3. Lifted types: values are pointers, lazily evaluated --- --- The first category can be stored in a 'ByteArray', and this allows types in --- category 3 that are simple wrappers around category 1 types to be stored --- more efficiently using a 'ByteArray'. This module provides the same facility --- for category 2 types. --- --- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These --- are arrays of pointers, but of category 2 values, so they are known to not --- be bottom. This allows types that are wrappers around such types to be stored --- in an array without an extra level of indirection. --- --- The way that the 'ArrayArray#' API works is that one can read and write --- 'ArrayArray#' values to the positions. This works because all category 2 --- types share a uniform representation, unlike unboxed values which are --- represented by varying (by type) numbers of bytes. However, using the --- this makes the internal API very unsafe to use, as one has to coerce values --- to and from 'ArrayArray#'. --- --- The API presented by this module is more type safe. 'UnliftedArray' and --- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and --- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things --- that are eligible to be stored. --- +GHC contains three general classes of value types: + + 1. Unboxed types: values are machine values made up of fixed numbers of bytes + 2. Unlifted types: values are pointers, but strictly evaluated + 3. Lifted types: values are pointers, lazily evaluated + +The first category can be stored in a 'ByteArray', and this allows types in +category 3 that are simple wrappers around category 1 types to be stored +more efficiently using a 'ByteArray'. This module provides the same facility +for category 2 types. + +GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These +are arrays of pointers, but of category 2 values, so they are known to not +be bottom. This allows types that are wrappers around such types to be stored +in an array without an extra level of indirection. + +The way that the 'ArrayArray#' API works is that one can read and write +'ArrayArray#' values to the positions. This works because all category 2 +types share a uniform representation, unlike unboxed values which are +represented by varying (by type) numbers of bytes. However, using the +this makes the internal API very unsafe to use, as one has to coerce values +to and from 'ArrayArray#'. + +The API presented by this module is more type safe. 'UnliftedArray' and +'MutableUnliftedArray' are parameterized by the type of arrays they contain, and +the coercions necessary are abstracted into a class, 'PrimUnlifted', of things +that are eligible to be stored. +-} module Z.Data.Array.UnliftedArray where import Control.Monad.Primitive diff --git a/Z/Data/Builder.hs b/Z/Data/Builder.hs --- a/Z/Data/Builder.hs +++ b/Z/Data/Builder.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} - {-| Module : Z.Data.Builder Description : Efficient serialization/format. diff --git a/Z/Data/Builder/Base.hs b/Z/Data/Builder/Base.hs --- a/Z/Data/Builder/Base.hs +++ b/Z/Data/Builder/Base.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} - {-| Module : Z.Data.Builder.Base Description : Efficient serialization/format. @@ -155,6 +144,8 @@ mconcat = foldr append (pure ()) {-# INLINE mconcat #-} +-- | This instance simple write literals' bytes into buffer, +-- which is different from 'stringUTF8' in that it DOES NOT PROVIDE UTF8 GUARANTEES! : instance (a ~ ()) => IsString (Builder a) where {-# INLINE fromString #-} fromString = stringModifiedUTF8 @@ -430,9 +421,8 @@ -- -- Illegal codepoints will be written as 'T.replacementChar's. -- --- Note, if you're trying to write string literals builders, and you know it doen't contain --- '\NUL' or surrgate codepoints, then you can open 'OverloadedStrings' and use 'Builder''s --- 'IsString' instance, it can save an extra UTF-8 validation. +-- This is different from writing string literals builders via @OverloadedStrings@, because string literals +-- do not provide UTF8 guarantees. -- -- This function will be rewritten into a memcpy if possible, (running a fast UTF-8 validation -- at runtime first). diff --git a/Z/Data/Builder/Numeric.hs b/Z/Data/Builder/Numeric.hs --- a/Z/Data/Builder/Numeric.hs +++ b/Z/Data/Builder/Numeric.hs @@ -1,15 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes #-} - {-| Module : Z.Data.Builder.Numeric Description : Textual numeric builders. @@ -497,16 +485,7 @@ -- | Format a 'FiniteBits' 'Integral' type into hex nibbles. hex :: forall a. (FiniteBits a, Integral a) => a -> Builder () -{-# SPECIALIZE INLINE hex :: Int -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Int8 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Int16 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Int32 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Int64 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Word -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Word8 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Word16 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Word32 -> Builder () #-} -{-# SPECIALIZE INLINE hex :: Word64 -> Builder () #-} +{-# INLINE hex #-} hex w = writeN hexSiz (go w (hexSiz-2)) where bitSiz = finiteBitSize (undefined :: a) @@ -528,16 +507,7 @@ -- | The UPPERCASED version of 'hex'. heX :: forall a. (FiniteBits a, Integral a) => a -> Builder () -{-# SPECIALIZE INLINE heX :: Int -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Int8 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Int16 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Int32 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Int64 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Word -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Word8 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Word16 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Word32 -> Builder () #-} -{-# SPECIALIZE INLINE heX :: Word64 -> Builder () #-} +{-# INLINE heX #-} heX w = writeN hexSiz (go w (hexSiz-2)) where bitSiz = finiteBitSize (undefined :: a) diff --git a/Z/Data/Builder/Numeric/DigitTable.hs b/Z/Data/Builder/Numeric/DigitTable.hs --- a/Z/Data/Builder/Numeric/DigitTable.hs +++ b/Z/Data/Builder/Numeric/DigitTable.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MagicHash #-} {-# LANGUAGE NoCPP #-} {-| diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} {-| Module : Z.Data.CBytes Description : Null-ternimated byte string. @@ -27,7 +19,7 @@ , unpack , null , length , empty, append, concat, intercalate, intercalateElem - , toBytes, fromBytes, toText, toTextMaybe, fromText + , toBytes, fromBytes, toText, toTextMaybe, fromText, toBuilder, buildCBytes , fromCString, fromCStringN , withCBytesUnsafe, withCBytes, allocCBytesUnsafe, allocCBytes -- re-export @@ -36,7 +28,6 @@ ) where import Control.DeepSeq -import Control.Exception (Exception, throwIO) import Control.Monad import Control.Monad.Primitive import Control.Monad.ST @@ -44,7 +35,6 @@ import Data.Foldable (foldlM) import Data.Hashable (Hashable(..)) import qualified Data.List as List -import Data.Typeable import Data.Primitive.PrimArray import Data.Word import Foreign.C.String @@ -65,11 +55,14 @@ zipWith) import Z.Data.Array import Z.Data.Array.Unaligned +import qualified Z.Data.Builder as B import qualified Z.Data.Text as T +import qualified Z.Data.Text.ShowT as T import Z.Data.Text.UTF8Codec (encodeCharModifiedUTF8, decodeChar) import qualified Z.Data.Vector.Base as V import Z.Foreign import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) -- | A efficient wrapper for short immutable null-terminated byte sequences which can be -- automatically freed by ghc garbage collector. @@ -149,6 +142,13 @@ hashWithSalt salt (CBytes pa@(PrimArray ba#)) = unsafeDupablePerformIO $ do V.c_fnv_hash_ba ba# 0 (sizeofPrimArray pa) salt +instance Arbitrary CBytes where + arbitrary = pack <$> arbitrary + shrink a = pack <$> shrink (unpack a) + +instance CoArbitrary CBytes where + coarbitrary = coarbitrary . unpack + -- | This instance peek bytes until @\NUL@(or input chunk ends), poke bytes with an extra \NUL terminator. instance Unaligned CBytes where {-# INLINE unalignedSize #-} @@ -181,6 +181,11 @@ pa <- unsafeFreezePrimArray mpa return (CBytes pa)) +-- | This instance provide UTF8 guarantee, illegal codepoints will be written as 'T.replacementChar's. +instance T.ShowT CBytes where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = T.stringUTF8 . show . unpack + append :: CBytes -> CBytes -> CBytes {-# INLINABLE append #-} append strA@(CBytes pa) strB@(CBytes pb) @@ -408,6 +413,18 @@ fromText :: T.Text -> CBytes {-# INLINABLE fromText #-} fromText = fromBytes . T.getUTF8Bytes + + +-- | Write 'CBytes' \'s byte sequence to buffer. +-- +-- This function is different from 'ShowT' instance in that it directly write byte sequence without +-- checking if it's UTF8 encoded. +toBuilder :: CBytes -> B.Builder () +toBuilder = B.bytes . toBytes + +-- | Build a 'CBytes' with builder, result will be trimmed down to first byte before @\NUL@ byte if there's any. +buildCBytes :: B.Builder a -> CBytes +buildCBytes = fromBytes . B.buildBytes -------------------------------------------------------------------------------- diff --git a/Z/Data/Generics/Utils.hs b/Z/Data/Generics/Utils.hs --- a/Z/Data/Generics/Utils.hs +++ b/Z/Data/Generics/Utils.hs @@ -1,15 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - module Z.Data.Generics.Utils ( ProductSize(..) diff --git a/Z/Data/JSON/Base.hs b/Z/Data/JSON/Base.hs --- a/Z/Data/JSON/Base.hs +++ b/Z/Data/JSON/Base.hs @@ -1,27 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PartialTypeSignatures #-} - {-| Module : Z.Data.JSON.Base Description : Fast JSON serialization/deserialization @@ -84,7 +60,7 @@ import qualified Data.Monoid as Monoid import Data.Primitive.Types (Prim) import qualified Data.Primitive.SmallArray as A -import Data.Proxy (Proxy (..)) +import Data.Proxy (Proxy(..)) import Data.Ratio (Ratio, (%), numerator, denominator) import Data.Scientific (Scientific, base10Exponent, toBoundedInteger) import qualified Data.Scientific as Scientific @@ -92,6 +68,7 @@ import Data.Tagged (Tagged (..)) import Data.Version (Version, parseVersion) import Data.Word +import Foreign.C.Types import GHC.Exts (Proxy#, proxy#) import GHC.Generics import GHC.Natural @@ -103,7 +80,7 @@ import qualified Z.Data.Parser as P import qualified Z.Data.Parser.Numeric as P import qualified Z.Data.Text as T -import qualified Z.Data.Text.Builder as TB +import qualified Z.Data.Text.ShowT as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Extra as V import qualified Z.Data.Vector.FlatIntMap as FIM @@ -169,12 +146,12 @@ -- | Text version 'encodeBytes'. encodeText :: EncodeJSON a => a -> T.Text {-# INLINE encodeText #-} -encodeText = TB.buildText . encodeTextBuilder +encodeText = T.buildText . encodeTextBuilder -- | JSON Docs are guaranteed to be valid UTF-8 texts, so we provide this. -encodeTextBuilder :: EncodeJSON a => a -> TB.TextBuilder () +encodeTextBuilder :: EncodeJSON a => a -> T.TextBuilder () {-# INLINE encodeTextBuilder #-} -encodeTextBuilder = TB.unsafeFromBuilder . encodeJSON +encodeTextBuilder = T.unsafeFromBuilder . encodeJSON -- | Run a 'Converter' with input value. convert :: (a -> Converter r) -> a -> Either ConvertError r @@ -204,14 +181,14 @@ instance Show ConvertError where -- TODO use standard format - show (ConvertError paths msg) = T.unpack . TB.buildText $ do + show (ConvertError paths msg) = T.unpack . T.buildText $ do "<" mapM_ renderPath (reverse paths) "> " - TB.text msg + T.text msg where - renderPath (Index ix) = TB.char7 '[' >> TB.int ix >> TB.char7 ']' - renderPath (Key k) = TB.char7 '.' >> (TB.unsafeFromBuilder $ JB.string k) + renderPath (Index ix) = T.char7 '[' >> T.int ix >> T.char7 ']' + renderPath (Key k) = T.char7 '.' >> (T.unsafeFromBuilder $ JB.string k) renderPath Embedded = "" -- | 'Converter' for convert result from JSON 'Value'. @@ -351,11 +328,11 @@ {-# INLINE withBoundedScientific #-} withBoundedScientific name f (Number x) | e <= 1024 = f x - | otherwise = fail' . TB.buildText $ do + | otherwise = fail' . T.buildText $ do "converting " - TB.text name + T.text name " failed, found a number with exponent " - TB.int e + T.int e ", but it must not be greater than 1024" where e = base10Exponent x withBoundedScientific name _ v = typeMismatch name "Number" v @@ -367,11 +344,11 @@ withBoundedIntegral name f (Number x) = case toBoundedInteger x of Just i -> f i - _ -> fail' . TB.buildText $ do + _ -> fail' . T.buildText $ do "converting " - TB.text name + T.text name "failed, value is either floating or will cause over or underflow " - TB.scientific x + T.scientific x withBoundedIntegral name _ v = typeMismatch name "Number" v withText :: T.Text -> (T.Text -> Converter a) -> Value -> Converter a @@ -804,13 +781,13 @@ instance GBuildLookup (S1 (MetaSel Nothing u ss ds) f) where {-# INLINE gBuildLookup #-} gBuildLookup _ siz name (Array v) - | siz' /= siz = fail' . TB.buildText $ do + | siz' /= siz = fail' . T.buildText $ do "converting " - TB.text name + T.text name " failed, product size mismatch, expected " - TB.int siz + T.int siz ", get" - TB.int siz' + T.int siz' | otherwise = pure v where siz' = V.length v gBuildLookup _ _ name x = typeMismatch name "Array" x @@ -818,13 +795,13 @@ instance GBuildLookup (S1 ((MetaSel (Just l) u ss ds)) f) where {-# INLINE gBuildLookup #-} gBuildLookup _ siz name (Object v) - | siz' /= siz = fail' . TB.buildText $ do + | siz' /= siz = fail' . T.buildText $ do "converting " - TB.text name + T.text name " failed, product size mismatch, expected " - TB.int siz + T.int siz ", get" - TB.int siz' + T.int siz' | otherwise = pure m where siz' = FM.size m m = FM.packVectorR v @@ -908,15 +885,15 @@ instance ToValue T.Text where {{-# INLINE toValue #-}; toValue = String;} instance EncodeJSON T.Text where {{-# INLINE encodeJSON #-}; encodeJSON = JB.string;} -instance FromValue TB.Str where +instance FromValue T.Str where {-# INLINE fromValue #-} - fromValue = withText "Str" (pure . TB.Str . T.unpack) -instance ToValue TB.Str where + fromValue = withText "Str" (pure . T.Str . T.unpack) +instance ToValue T.Str where {-# INLINE toValue #-} - toValue = String . T.pack . TB.chrs -instance EncodeJSON TB.Str where + toValue = String . T.pack . T.chrs +instance EncodeJSON T.Str where {-# INLINE encodeJSON #-} - encodeJSON = JB.string . T.pack . TB.chrs + encodeJSON = JB.string . T.pack . T.chrs instance FromValue Scientific where {{-# INLINE fromValue #-}; fromValue = withScientific "Scientific" pure;} instance ToValue Scientific where {{-# INLINE toValue #-}; toValue = Number;} @@ -971,7 +948,7 @@ instance ToValue a => ToValue (FIM.FlatIntMap a) where {-# INLINE toValue #-} toValue = Object . V.map' toKV . FIM.sortedKeyValues - where toKV (V.IPair i x) = let !k = TB.buildText (TB.int i) + where toKV (V.IPair i x) = let !k = T.buildText (T.int i) !v = toValue x in (k, v) instance EncodeJSON a => EncodeJSON (FIM.FlatIntMap a) where @@ -1132,9 +1109,9 @@ fromValue = withBoundedScientific "Integer" $ \ n -> case Scientific.floatingOrInteger n :: Either Double Integer of Right x -> pure x - Left _ -> fail' . TB.buildText $ do + Left _ -> fail' . T.buildText $ do "converting Integer failed, unexpected floating number " - TB.scientific n + T.scientific n instance ToValue Integer where {-# INLINE toValue #-} toValue = Number . fromIntegral @@ -1146,14 +1123,14 @@ {-# INLINE fromValue #-} fromValue = withBoundedScientific "Natural" $ \ n -> if n < 0 - then fail' . TB.buildText $ do + then fail' . T.buildText $ do "converting Natural failed, unexpected negative number " - TB.scientific n + T.scientific n else case Scientific.floatingOrInteger n :: Either Double Natural of Right x -> pure x - Left _ -> fail' . TB.buildText $ do + Left _ -> fail' . T.buildText $ do "converting Natural failed, unexpected floating number " - TB.scientific n + T.scientific n instance ToValue Natural where {-# INLINE toValue #-} toValue = Number . fromIntegral @@ -1291,6 +1268,89 @@ deriving newtype instance EncodeJSON a => EncodeJSON (Identity a) deriving newtype instance EncodeJSON a => EncodeJSON (Const a b) deriving newtype instance EncodeJSON b => EncodeJSON (Tagged a b) + +-------------------------------------------------------------------------------- + +deriving newtype instance FromValue CChar +deriving newtype instance FromValue CSChar +deriving newtype instance FromValue CUChar +deriving newtype instance FromValue CShort +deriving newtype instance FromValue CUShort +deriving newtype instance FromValue CInt +deriving newtype instance FromValue CUInt +deriving newtype instance FromValue CLong +deriving newtype instance FromValue CULong +deriving newtype instance FromValue CPtrdiff +deriving newtype instance FromValue CSize +deriving newtype instance FromValue CWchar +deriving newtype instance FromValue CSigAtomic +deriving newtype instance FromValue CLLong +deriving newtype instance FromValue CULLong +deriving newtype instance FromValue CBool +deriving newtype instance FromValue CIntPtr +deriving newtype instance FromValue CUIntPtr +deriving newtype instance FromValue CIntMax +deriving newtype instance FromValue CUIntMax +deriving newtype instance FromValue CClock +deriving newtype instance FromValue CTime +deriving newtype instance FromValue CUSeconds +deriving newtype instance FromValue CSUSeconds +deriving newtype instance FromValue CFloat +deriving newtype instance FromValue CDouble + +deriving newtype instance ToValue CChar +deriving newtype instance ToValue CSChar +deriving newtype instance ToValue CUChar +deriving newtype instance ToValue CShort +deriving newtype instance ToValue CUShort +deriving newtype instance ToValue CInt +deriving newtype instance ToValue CUInt +deriving newtype instance ToValue CLong +deriving newtype instance ToValue CULong +deriving newtype instance ToValue CPtrdiff +deriving newtype instance ToValue CSize +deriving newtype instance ToValue CWchar +deriving newtype instance ToValue CSigAtomic +deriving newtype instance ToValue CLLong +deriving newtype instance ToValue CULLong +deriving newtype instance ToValue CBool +deriving newtype instance ToValue CIntPtr +deriving newtype instance ToValue CUIntPtr +deriving newtype instance ToValue CIntMax +deriving newtype instance ToValue CUIntMax +deriving newtype instance ToValue CClock +deriving newtype instance ToValue CTime +deriving newtype instance ToValue CUSeconds +deriving newtype instance ToValue CSUSeconds +deriving newtype instance ToValue CFloat +deriving newtype instance ToValue CDouble + +deriving newtype instance EncodeJSON CChar +deriving newtype instance EncodeJSON CSChar +deriving newtype instance EncodeJSON CUChar +deriving newtype instance EncodeJSON CShort +deriving newtype instance EncodeJSON CUShort +deriving newtype instance EncodeJSON CInt +deriving newtype instance EncodeJSON CUInt +deriving newtype instance EncodeJSON CLong +deriving newtype instance EncodeJSON CULong +deriving newtype instance EncodeJSON CPtrdiff +deriving newtype instance EncodeJSON CSize +deriving newtype instance EncodeJSON CWchar +deriving newtype instance EncodeJSON CSigAtomic +deriving newtype instance EncodeJSON CLLong +deriving newtype instance EncodeJSON CULLong +deriving newtype instance EncodeJSON CBool +deriving newtype instance EncodeJSON CIntPtr +deriving newtype instance EncodeJSON CUIntPtr +deriving newtype instance EncodeJSON CIntMax +deriving newtype instance EncodeJSON CUIntMax +deriving newtype instance EncodeJSON CClock +deriving newtype instance EncodeJSON CTime +deriving newtype instance EncodeJSON CUSeconds +deriving newtype instance EncodeJSON CSUSeconds +deriving newtype instance EncodeJSON CFloat +deriving newtype instance EncodeJSON CDouble -------------------------------------------------------------------------------- diff --git a/Z/Data/JSON/Builder.hs b/Z/Data/JSON/Builder.hs --- a/Z/Data/JSON/Builder.hs +++ b/Z/Data/JSON/Builder.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE TypeApplications #-} - {-| Module : Z.Data.JSON.Builder Description : JSON representation and builders @@ -33,19 +24,12 @@ , Value(..) ) where -import Control.Monad -import Control.Monad.ST.Unsafe (unsafeIOToST) -import Data.Primitive.PrimArray -import Data.Word -import GHC.Prim (unsafeCoerce#) -import qualified Z.Data.Builder as B -import qualified Z.Data.Builder.Base as B -import qualified Z.Data.Text as T -import Z.Data.Vector.Base as V -import Z.Foreign -import Z.Data.JSON.Value (Value(..)) +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Text.ShowT as T +import Z.Data.Vector.Base as V +import Z.Data.JSON.Value (Value(..)) -#define DOUBLE_QUOTE 34 -- | Use @:@ as separator to connect a label(no need to escape, only add quotes) with field builders. kv :: T.Text -> B.Builder () -> B.Builder () @@ -100,20 +84,4 @@ -- string :: T.Text -> B.Builder () {-# INLINE string #-} -string (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do - let siz = escape_json_string_length ba# s l - B.ensureN siz - B.Builder (\ _ k (B.Buffer mba@(MutablePrimArray mba#) i) -> do - if siz == l+2 -- no need to escape - then do - writePrimArray mba i DOUBLE_QUOTE - copyPrimArray mba (i+1) ba s l - writePrimArray mba (i+1+l) DOUBLE_QUOTE - else void $ unsafeIOToST (escape_json_string ba# s l (unsafeCoerce# mba#) i) - k () (B.Buffer mba (i+siz))) - -foreign import ccall unsafe escape_json_string_length - :: BA# Word8 -> Int -> Int -> Int - -foreign import ccall unsafe escape_json_string - :: BA# Word8 -> Int -> Int -> MBA# Word8 -> Int -> IO Int +string = T.escapeTextJSON diff --git a/Z/Data/JSON/Value.hs b/Z/Data/JSON/Value.hs --- a/Z/Data/JSON/Value.hs +++ b/Z/Data/JSON/Value.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnliftedFFITypes #-} - {-| Module : Z.Data.JSON.Value Description : JSON representation and parsers @@ -49,7 +40,6 @@ import Control.DeepSeq import Data.Bits ((.&.)) import Data.Functor -import Data.Primitive.PrimArray import Data.Scientific (Scientific, scientific) import Data.Typeable import Data.Word @@ -57,7 +47,7 @@ import qualified Z.Data.Parser as P import Z.Data.Parser (()) import qualified Z.Data.Text as T -import Z.Data.Text.Builder (ToText) +import Z.Data.Text.ShowT (ShowT(..)) import Z.Data.Vector.Base as V import Z.Data.Vector.Extra as V import Z.Foreign @@ -101,7 +91,7 @@ | Number {-# UNPACK #-} !Scientific | Bool !Bool | Null - deriving (Eq, Show, Typeable, Generic, ToText) + deriving (Eq, Show, Typeable, Generic, ShowT) instance NFData Value where {-# INLINE rnf #-} diff --git a/Z/Data/Parser.hs b/Z/Data/Parser.hs --- a/Z/Data/Parser.hs +++ b/Z/Data/Parser.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Data.Parser Description : Efficient deserialization/parse. diff --git a/Z/Data/Parser/Base.hs b/Z/Data/Parser/Base.hs --- a/Z/Data/Parser/Base.hs +++ b/Z/Data/Parser/Base.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Data.Parser.Base Description : Efficient deserialization/parse. @@ -244,6 +236,7 @@ else Partial (ensureNPartial l inp kf k) where {-# INLINABLE ensureNPartial #-} + ensureNPartial :: forall r. Int -> V.PrimVector Word8 -> (ParseError -> ParseStep r) -> (() -> ParseStep r) -> ParseStep r ensureNPartial l0 inp0 kf k = let go acc !l = \ inp -> do let l' = V.length inp @@ -367,7 +360,7 @@ -- the predicate on each chunk of the input until one chunk got splited to -- @Right (V.Bytes, V.Bytes)@ or the input ends. -- -scanChunks :: s -> (s -> V.Bytes -> Either s (V.Bytes, V.Bytes, s)) -> Parser (V.Bytes, s) +scanChunks :: forall s. s -> (s -> V.Bytes -> Either s (V.Bytes, V.Bytes, s)) -> Parser (V.Bytes, s) {-# INLINE scanChunks #-} scanChunks s0 consume = Parser (\ _ k inp -> case consume s0 inp of @@ -376,6 +369,7 @@ where -- we want to inline consume if possible {-# INLINABLE scanChunksPartial #-} + scanChunksPartial :: forall r. s -> ((V.PrimVector Word8, s) -> ParseStep r) -> V.PrimVector Word8 -> ParseStep r scanChunksPartial s0' k inp0 = let go s acc = \ inp -> if V.null inp @@ -530,6 +524,7 @@ where -- we want to inline p if possible {-# INLINABLE skipWhilePartial #-} + skipWhilePartial :: forall r. (() -> ParseStep r) -> ParseStep r skipWhilePartial k = let go = \ inp -> if V.null inp @@ -573,6 +568,7 @@ else k want rest) where {-# INLINABLE takeTillPartial #-} + takeTillPartial :: forall r. (V.PrimVector Word8 -> ParseStep r) -> V.PrimVector Word8 -> ParseStep r takeTillPartial k want = let go acc = \ inp -> if V.null inp @@ -598,6 +594,7 @@ where -- we want to inline p if possible {-# INLINABLE takeWhilePartial #-} + takeWhilePartial :: forall r. (V.PrimVector Word8 -> ParseStep r) -> V.PrimVector Word8 -> ParseStep r takeWhilePartial k want = let go acc = \ inp -> if V.null inp diff --git a/Z/Data/Parser/Numeric.hs b/Z/Data/Parser/Numeric.hs --- a/Z/Data/Parser/Numeric.hs +++ b/Z/Data/Parser/Numeric.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE CPP #-} - {-| Module : Z.Data.Parser.Numeric Description : Textual numeric parsers. diff --git a/Z/Data/PrimRef/PrimIORef.hs b/Z/Data/PrimRef/PrimIORef.hs --- a/Z/Data/PrimRef/PrimIORef.hs +++ b/Z/Data/PrimRef/PrimIORef.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE BangPatterns #-} - {-| Module : Z.Data.PrimIORef Copyright : (c) Dong Han 2017~2019 diff --git a/Z/Data/PrimRef/PrimSTRef.hs b/Z/Data/PrimRef/PrimSTRef.hs --- a/Z/Data/PrimRef/PrimSTRef.hs +++ b/Z/Data/PrimRef/PrimSTRef.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MagicHash #-} - {-| Module : Z.Data.PrimRef.PrimSTRef Copyright : (c) Dong Han 2017~2019 diff --git a/Z/Data/Text.hs b/Z/Data/Text.hs --- a/Z/Data/Text.hs +++ b/Z/Data/Text.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternSynonyms #-} - {-| Module : Z.Data.Text Description : Unicode text processing diff --git a/Z/Data/Text/Base.hs b/Z/Data/Text/Base.hs --- a/Z/Data/Text/Base.hs +++ b/Z/Data/Text/Base.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} - {-| Module : Z.Data.Text.Base Description : Unicode text processing @@ -121,6 +112,8 @@ , c_ascii_validate_addr ) where +#define DOUBLE_QUOTE 34 + import Control.DeepSeq import Control.Exception import Control.Monad.ST @@ -158,7 +151,7 @@ -- newtype Text = Text { getUTF8Bytes :: Bytes -- ^ Extract UTF-8 encoded 'Bytes' from 'Text' - } deriving (Semigroup, Monoid, Typeable) + } deriving newtype (Monoid, Semigroup) instance Eq Text where Text b1 == Text b2 = b1 == b2 @@ -168,12 +161,28 @@ Text b1 `compare` Text b2 = b1 `compare` b2 -- UTF-8 encoding property {-# INLINE compare #-} +-- | The escaping rules is different from 'String' 's 'Show' instance, see "Z.Data.Text.Builder.escapeTextJSON" instance Show Text where - showsPrec p t = showsPrec p (unpack t) + show = unpack . escapeTextJSON + where + escapeTextJSON (Text (V.PrimVector ba@(PrimArray ba#) s l)) = unsafeDupablePerformIO $ do + let siz = escape_json_string_length ba# s l + mba@(MutablePrimArray mba#) <- newPrimArray siz + if siz == l+2 -- no need to escape + then do + writePrimArray mba 0 DOUBLE_QUOTE + copyPrimArray mba 1 ba s l + writePrimArray mba (l+1) DOUBLE_QUOTE + else void $ (escape_json_string ba# s l mba# 0) + ba' <- unsafeFreezePrimArray mba + return (Text (V.PrimVector ba' 0 siz)) -instance Read Text where - readsPrec p str = [ (pack x, y) | (x, y) <- readsPrec p str ] +foreign import ccall unsafe escape_json_string_length + :: ByteArray# -> Int -> Int -> Int +foreign import ccall unsafe escape_json_string + :: ByteArray# -> Int -> Int -> MutableByteArray# RealWorld -> Int -> IO Int + instance NFData Text where rnf (Text bs) = rnf bs @@ -704,6 +713,7 @@ fromVector (V.PrimVector arr s l) = Text (V.createN l (go s 0)) where end = s+l + go :: forall s. Int -> Int -> MutablePrimArray s Word8 -> ST s Int go !i !j !marr | i >= end = return j | otherwise = do @@ -717,6 +727,7 @@ toVector (Text (V.PrimVector arr s l)) = V.createN (l*4) (go s 0) where end = s+l + go :: forall s. Int -> Int -> MutablePrimArray s Char -> ST s Int go !i !j !marr | i >= end = return j | otherwise = do diff --git a/Z/Data/Text/Builder.hs b/Z/Data/Text/Builder.hs deleted file mode 100644 --- a/Z/Data/Text/Builder.hs +++ /dev/null @@ -1,598 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveAnyClass #-} - -{-| -Module : Z.Data.Text.Builder -Description : UTF8 compatible builders. -Copyright : (c) Dong Han, 2017-2019 -License : BSD -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : non-portable - -Base on UTF8 compatible textual builders from 'Z.Data.Builder', we provide a newtype wrapper -'TextBuilder' which can be directly used to build 'Text'. - -We also provide faster alternative to 'Show' class, i.e. 'ToText', which also provides 'Generic' -based instances deriving. - --} - -module Z.Data.Text.Builder - ( -- * ToText class - ToText(..), toText, toBuilder, toBytes, toString - -- * Str newtype - , Str(..) - -- * Textual Builder - , TextBuilder - , getBuilder - , unsafeFromBuilder - , buildText - -- * Basic UTF8 builders - , stringUTF8, charUTF8, string7, char7, text - -- * Numeric builders - -- ** Integral type formatting - , B.IFormat(..) - , B.defaultIFormat - , B.Padding(..) - , int - , intWith - , integer - -- ** Fixded size hexidecimal formatting - , hex, heX - -- ** IEEE float formating - , B.FFormat(..) - , double - , doubleWith - , float - , floatWith - , scientific - , scientificWith - -- * Builder helpers - , paren, parenWhen, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList - ) where - -import Control.Monad -import qualified Data.Scientific as Sci -import Data.String -import Data.Bits -import Data.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.Int -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Monoid as Monoid -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio, numerator, denominator) -import Data.Tagged (Tagged (..)) -import Data.Word -import qualified Data.Semigroup as Semigroup -import Data.Typeable -import GHC.Natural -import GHC.Generics -import Data.Version -import Data.Primitive.Types -import qualified Z.Data.Builder as B -import qualified Z.Data.Text.Base as T -import Z.Data.Text.Base (Text(..)) -import qualified Z.Data.Vector.Base as V -import Text.Read (Read(..)) -import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) - --- | Buidlers which guarantee UTF-8 encoding, thus can be used to build --- text directly. --- --- Notes on 'IsString' instance: It's recommended to use 'IsString' instance, there's a rewrite rule to --- turn encoding loop into a memcpy, which is much faster (the same rule also apply to 'stringUTF8'). --- Different from @Builder ()@, @TextBuilder ()@'s 'IsString' instance will give you desired UTF8 guarantees: --- --- * @\NUL@ will be written directly as @\x00@. --- --- * @\xD800@ ~ @\xDFFF@ will be replaced by replacement char. --- -newtype TextBuilder a = TextBuilder { getBuilder :: B.Builder a } - deriving newtype (Functor, Applicative, Monad) - -deriving newtype instance Semigroup (TextBuilder ()) -deriving newtype instance Monoid (TextBuilder ()) - -instance (a ~ ()) => IsString (TextBuilder a) where - {-# INLINE fromString #-} - fromString = TextBuilder <$> B.stringUTF8 - -instance Arbitrary (TextBuilder ()) where - arbitrary = TextBuilder . B.text <$> arbitrary - shrink b = TextBuilder . B.text <$> shrink (buildText b) - -instance CoArbitrary (TextBuilder ()) where - coarbitrary = coarbitrary . buildText - -instance Show (TextBuilder a) where - show = show . buildText - -instance ToText (TextBuilder a) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ b = quotes (void b) - --- | Build a 'Text' using 'TextBuilder', which provide UTF-8 encoding guarantee. -buildText :: TextBuilder a -> Text -{-# INLINE buildText #-} -buildText = Text . B.buildBytes . getBuilder - --- | Unsafely turn a 'B.Builder' into 'TextBuilder', thus it's user's responsibility to --- ensure only UTF-8 complied bytes are written. -unsafeFromBuilder :: B.Builder a -> TextBuilder a -{-# INLINE unsafeFromBuilder #-} -unsafeFromBuilder = TextBuilder - --------------------------------------------------------------------------------- - --- | Turn 'String' into 'TextBuilder' with UTF8 encoding --- --- Illegal codepoints will be written as 'T.replacementChar's. This function will be rewritten into a memcpy if possible, (running a fast UTF-8 validation at runtime first). -stringUTF8 :: String -> TextBuilder () -{-# INLINE stringUTF8 #-} -stringUTF8 = TextBuilder . B.stringUTF8 - --- | Turn 'Char' into 'TextBuilder' with UTF8 encoding --- --- Illegal codepoints will be written as 'T.replacementChar's. -charUTF8 :: Char -> TextBuilder () -{-# INLINE charUTF8 #-} -charUTF8 = TextBuilder . B.charUTF8 - --- | Turn 'String' into 'TextBuilder' with ASCII7 encoding --- --- Codepoints beyond @'\x7F'@ will be chopped. -string7 :: String -> TextBuilder () -{-# INLINE string7 #-} -string7 = TextBuilder . B.string7 - --- | Turn 'Char' into 'TextBuilder' with ASCII7 encoding --- --- Codepoints beyond @'\x7F'@ will be chopped. -char7 :: Char -> TextBuilder () -{-# INLINE char7 #-} -char7 = TextBuilder . B.char7 - --- | Write UTF8 encoded 'T.Text' using 'Builder'. --- --- Note, if you're trying to write string literals builders, --- please open 'OverloadedStrings' and use 'Builder's 'IsString' instance, --- it will be rewritten into a memcpy. -text :: T.Text -> TextBuilder () -{-# INLINE text #-} -text = TextBuilder . B.text - --------------------------------------------------------------------------------- - --- | @int = intWith defaultIFormat@ -int :: (Integral a, Bounded a) => a -> TextBuilder () -{-# INLINE int #-} -int = TextBuilder . B.int - --- | Format a 'Bounded' 'Integral' type like @Int@ or @Word16@ into decimal ascii digits. -intWith :: (Integral a, Bounded a) - => B.IFormat - -> a - -> TextBuilder () -{-# INLINE intWith #-} -intWith fmt x = TextBuilder $ B.intWith fmt x - --- | Format a 'Integer' into decimal ascii digits. -integer :: Integer -> TextBuilder () -{-# INLINE integer #-} -integer = TextBuilder . B.integer - --- | Format a 'FiniteBits' 'Integral' type into hex nibbles. -hex :: (FiniteBits a, Integral a) => a -> TextBuilder () -{-# INLINE hex #-} -hex = TextBuilder . B.hex - --- | The UPPERCASED version of 'hex'. -heX :: (FiniteBits a, Integral a) => a -> TextBuilder () -{-# INLINE heX #-} -heX = TextBuilder . B.heX - --- | Decimal encoding of an IEEE 'Float'. --- --- Using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. -float :: Float -> TextBuilder () -{-# INLINE float #-} -float = TextBuilder . B.float - --- | Format single-precision float using drisu3 with dragon4 fallback. -floatWith :: B.FFormat - -> Maybe Int -- ^ Number of decimal places to render. - -> Float - -> TextBuilder () -{-# INLINE floatWith #-} -floatWith fmt ds x = TextBuilder (B.floatWith fmt ds x) - - --- | Decimal encoding of an IEEE 'Double'. --- --- Using standard decimal notation for arguments whose absolute value lies --- between @0.1@ and @9,999,999@, and scientific notation otherwise. -double :: Double -> TextBuilder () -{-# INLINE double #-} -double = TextBuilder . B.double - --- | Format double-precision float using drisu3 with dragon4 fallback. -doubleWith :: B.FFormat - -> Maybe Int -- ^ Number of decimal places to render. - -> Double - -> TextBuilder () -{-# INLINE doubleWith #-} -doubleWith fmt ds x = TextBuilder (B.doubleWith fmt ds x) - - --- | A @Builder@ which renders a scientific number to full --- precision, using standard decimal notation for arguments whose --- absolute value lies between @0.1@ and @9,999,999@, and scientific --- notation otherwise. -scientific :: Sci.Scientific -> TextBuilder () -{-# INLINE scientific #-} -scientific = TextBuilder . B.scientific - --- | Like 'scientific' but provides rendering options. -scientificWith :: B.FFormat - -> Maybe Int -- ^ Number of decimal places to render. - -> Sci.Scientific - -> TextBuilder () -{-# INLINE scientificWith #-} -scientificWith fmt ds x = TextBuilder (B.scientificWith fmt ds x) - --------------------------------------------------------------------------------- - --- | add @(...)@ to original builder. -paren :: TextBuilder () -> TextBuilder () -{-# INLINE paren #-} -paren (TextBuilder b) = TextBuilder (B.paren b) - --- | Add "(..)" around builders when condition is met, otherwise add nothing. --- --- This is useful when defining 'ToText' instances. -parenWhen :: Bool -> TextBuilder () -> TextBuilder () -{-# INLINE parenWhen #-} -parenWhen True b = paren b -parenWhen _ b = b - --- | add @{...}@ to original builder. -curly :: TextBuilder () -> TextBuilder () -{-# INLINE curly #-} -curly (TextBuilder b) = TextBuilder (B.curly b) - --- | add @[...]@ to original builder. -square :: TextBuilder () -> TextBuilder () -{-# INLINE square #-} -square (TextBuilder b) = TextBuilder (B.square b) - --- | add @<...>@ to original builder. -angle :: TextBuilder () -> TextBuilder () -{-# INLINE angle #-} -angle (TextBuilder b) = TextBuilder (B.angle b) - --- | add @"..."@ to original builder. -quotes :: TextBuilder () -> TextBuilder () -{-# INLINE quotes #-} -quotes (TextBuilder b) = TextBuilder (B.quotes b) - --- | add @'...'@ to original builder. -squotes :: TextBuilder () -> TextBuilder () -{-# INLINE squotes #-} -squotes (TextBuilder b) = TextBuilder (B.squotes b) - --- | write an ASCII @:@ -colon :: TextBuilder () -{-# INLINE colon #-} -colon = TextBuilder B.colon - --- | write an ASCII @,@ -comma :: TextBuilder () -{-# INLINE comma #-} -comma = TextBuilder B.comma - --- | Use separator to connect a vector of builders. -intercalateVec :: (V.Vec v a) - => TextBuilder () -- ^ the seperator - -> (a -> TextBuilder ()) -- ^ value formatter - -> v a -- ^ value list - -> TextBuilder () -{-# INLINE intercalateVec #-} -intercalateVec (TextBuilder s) f = TextBuilder . B.intercalateVec s (getBuilder . f) - --- | Use separator to connect a list of builders. -intercalateList :: TextBuilder () -- ^ the seperator - -> (a -> TextBuilder ()) -- ^ value formatter - -> [a] -- ^ value vector - -> TextBuilder () -{-# INLINE intercalateList #-} -intercalateList (TextBuilder s) f = TextBuilder . B.intercalateList s (getBuilder . f) - --------------------------------------------------------------------------------- --- | Newtype wrapper for @[Char]@ to provide textual instances. --- --- We didn't provide special treatment to differentiate instances between @[a]@ and @[Char]@ --- in various classes, e.g. 'Z.Data.JSON.ToJSON'. --- --- This newtype is therefore to provide instances similar to @T.Text@, in case you really --- need to wrap a 'String'. --- --- >>> Z.Data.JSON.encodeText ("abc" :: String) --- > "[\"a\",\"b\",\"c\"]" -- Just like any other [a]'s instance --- >>> Z.Data.JSON.encodeText . Str $ ("abc" :: String) --- > "\"abc\"" --- -newtype Str = Str { chrs :: [Char] } deriving stock (Eq, Ord, Data, Typeable, Generic) - -instance Show Str where show = show . chrs -instance Read Str where readPrec = Str <$> readPrec - -instance ToText Str where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = TextBuilder . B.string8 . show - --------------------------------------------------------------------------------- --- Data types --- --- | A class similar to 'Show', serving the purpose that quickly convert a data type --- to a 'Text' value. -class ToText a where - toTextBuilder :: Int -> a -> TextBuilder () - default toTextBuilder :: (Generic a, GToText (Rep a)) => Int -> a -> TextBuilder () - toTextBuilder p = gToTextBuilder p . from - -class GToText f where - gToTextBuilder :: Int -> f a -> TextBuilder () - - -class GFieldToText f where - gFieldToTextBuilder :: B.Builder () -> Int -> f a -> B.Builder () - -instance (GFieldToText a, GFieldToText b) => GFieldToText (a :*: b) where - {-# INLINE gFieldToTextBuilder #-} - gFieldToTextBuilder sep p (a :*: b) = - gFieldToTextBuilder sep p a >> sep >> gFieldToTextBuilder sep p b - -instance (GToText f) => GFieldToText (S1 (MetaSel Nothing u ss ds) f) where - {-# INLINE gFieldToTextBuilder #-} - gFieldToTextBuilder _ p (M1 x) = getBuilder (gToTextBuilder p x) - -instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where - {-# INLINE gFieldToTextBuilder #-} - gFieldToTextBuilder _ _ m1@(M1 x) = - B.stringModifiedUTF8 (selName m1) >> " = " >> getBuilder (gToTextBuilder 0 x) - -instance GToText V1 where - {-# INLINE gToTextBuilder #-} - gToTextBuilder _ = error "Z.Data.TextBuilder: empty data type" - -instance (GToText f, GToText g) => GToText (f :+: g) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder p (L1 x) = gToTextBuilder p x - gToTextBuilder p (R1 x) = gToTextBuilder p x - --- | Constructor without payload, convert to String -instance (Constructor c) => GToText (C1 c U1) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder _ m1 = - TextBuilder . B.stringModifiedUTF8 $ conName m1 - --- | Constructor with payloads -instance (GFieldToText (S1 sc f), Constructor c) => GToText (C1 c (S1 sc f)) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder p m1@(M1 x) = - parenWhen (p > 10) . TextBuilder $ do - B.stringModifiedUTF8 $ conName m1 - B.char8 ' ' - if conIsRecord m1 - then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x - else gFieldToTextBuilder (B.char7 ' ') 11 x - -instance (GFieldToText (a :*: b), Constructor c) => GToText (C1 c (a :*: b)) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder p m1@(M1 x) = - case conFixity m1 of - Prefix -> parenWhen (p > 10) . TextBuilder $ do - B.stringModifiedUTF8 $ conName m1 - B.char8 ' ' - if conIsRecord m1 - then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x - else gFieldToTextBuilder (B.char7 ' ') 11 x - Infix _ p' -> parenWhen (p > p') . TextBuilder $ do - gFieldToTextBuilder - (B.char8 ' ' >> B.stringModifiedUTF8 (conName m1) >> B.char8 ' ') (p'+1) x - -instance ToText a => GToText (K1 i a) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder p (K1 x) = toTextBuilder p x - --------------------------------------------------------------------------------- --- Data types -instance GToText f => GToText (D1 c f) where - {-# INLINE gToTextBuilder #-} - gToTextBuilder p (M1 x) = gToTextBuilder p x - - --- | Directly convert data to 'Text'. -toText :: ToText a => a -> Text -{-# INLINE toText #-} -toText = buildText . toTextBuilder 0 - --- | Directly convert data to 'B.Builder'. -toBuilder :: ToText a => a -> B.Builder () -{-# INLINE toBuilder #-} -toBuilder = getBuilder . toTextBuilder 0 - --- | Directly convert data to 'V.Bytes'. -toBytes :: ToText a => a -> V.Bytes -{-# INLINE toBytes #-} -toBytes = B.buildBytes . toBuilder - --- | Faster 'show' replacement. -toString :: ToText a => a -> String -{-# INLINE toString #-} -toString = T.unpack . toText - -instance ToText Bool where - {-# INLINE toTextBuilder #-} - toTextBuilder _ True = TextBuilder "True" - toTextBuilder _ _ = TextBuilder "False" - -instance ToText Char where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = TextBuilder . B.string8 . show - -instance ToText Double where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = double;} -instance ToText Float where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = float;} - -instance ToText Int where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Int8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Int16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Int32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Int64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Word where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Word8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Word16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Word32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} -instance ToText Word64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} - -instance ToText Integer where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer;} -instance ToText Natural where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer . fromIntegral} -instance ToText Ordering where - {-# INLINE toTextBuilder #-} - toTextBuilder _ GT = TextBuilder "GT" - toTextBuilder _ EQ = TextBuilder "EQ" - toTextBuilder _ _ = TextBuilder "LT" - -instance ToText () where - {-# INLINE toTextBuilder #-} - toTextBuilder _ () = TextBuilder "()" - -instance ToText Version where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = stringUTF8 . show - --- | To keep sync with 'Show' instance's escaping rule, we reuse show here, so it won't be as fast as memcpy. -instance ToText Text where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = stringUTF8 . show - -instance ToText Sci.Scientific where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = scientific - -instance ToText a => ToText [a] where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = square . intercalateList comma (toTextBuilder 0) - -instance ToText a => ToText (V.Vector a) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) - -instance (Prim a, ToText a) => ToText (V.PrimVector a) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) - -instance (ToText a, ToText b) => ToText (a, b) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - -instance (ToText a, ToText b, ToText c) => ToText (a, b, c) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b, c) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - >> comma >> toTextBuilder 0 c - -instance (ToText a, ToText b, ToText c, ToText d) => ToText (a, b, c, d) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b, c, d) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - >> comma >> toTextBuilder 0 c - >> comma >> toTextBuilder 0 d - -instance (ToText a, ToText b, ToText c, ToText d, ToText e) => ToText (a, b, c, d, e) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b, c, d, e) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - >> comma >> toTextBuilder 0 c - >> comma >> toTextBuilder 0 d - >> comma >> toTextBuilder 0 e - -instance (ToText a, ToText b, ToText c, ToText d, ToText e, ToText f) => ToText (a, b, c, d, e, f) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b, c, d, e, f) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - >> comma >> toTextBuilder 0 c - >> comma >> toTextBuilder 0 d - >> comma >> toTextBuilder 0 e - >> comma >> toTextBuilder 0 f - -instance (ToText a, ToText b, ToText c, ToText d, ToText e, ToText f, ToText g) => ToText (a, b, c, d, e, f, g) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ (a, b, c, d, e, f, g) = paren $ toTextBuilder 0 a - >> comma >> toTextBuilder 0 b - >> comma >> toTextBuilder 0 c - >> comma >> toTextBuilder 0 d - >> comma >> toTextBuilder 0 e - >> comma >> toTextBuilder 0 f - >> comma >> toTextBuilder 0 g - -instance ToText a => ToText (Maybe a) where - {-# INLINE toTextBuilder #-} - toTextBuilder p (Just x) = parenWhen (p > 10) $ do TextBuilder "Just " - toTextBuilder 11 x - toTextBuilder _ _ = TextBuilder "Nothing" - -instance (ToText a, ToText b) => ToText (Either a b) where - {-# INLINE toTextBuilder #-} - toTextBuilder p (Left x) = parenWhen (p > 10) $ do TextBuilder "Left " - toTextBuilder 11 x - toTextBuilder p (Right x) = parenWhen (p > 10) $ do TextBuilder "Right " - toTextBuilder 11 x - -instance (ToText a, Integral a) => ToText (Ratio a) where - {-# INLINE toTextBuilder #-} - toTextBuilder p r = parenWhen (p > 10) $ do toTextBuilder 8 (numerator r) - TextBuilder " % " - toTextBuilder 8 (denominator r) - -instance HasResolution a => ToText (Fixed a) where - {-# INLINE toTextBuilder #-} - toTextBuilder _ = TextBuilder . B.string8 . show - -deriving anyclass instance ToText a => ToText (Semigroup.Min a) -deriving anyclass instance ToText a => ToText (Semigroup.Max a) -deriving anyclass instance ToText a => ToText (Semigroup.First a) -deriving anyclass instance ToText a => ToText (Semigroup.Last a) -deriving anyclass instance ToText a => ToText (Semigroup.WrappedMonoid a) -deriving anyclass instance ToText a => ToText (Semigroup.Dual a) -deriving anyclass instance ToText a => ToText (Monoid.First a) -deriving anyclass instance ToText a => ToText (Monoid.Last a) -deriving anyclass instance ToText a => ToText (NonEmpty a) -deriving anyclass instance ToText a => ToText (Identity a) -deriving anyclass instance ToText a => ToText (Const a b) -deriving anyclass instance ToText (Proxy a) -deriving anyclass instance ToText b => ToText (Tagged a b) -deriving anyclass instance ToText (f (g a)) => ToText (Compose f g a) -deriving anyclass instance (ToText (f a), ToText (g a)) => ToText (Product f g a) -deriving anyclass instance (ToText (f a), ToText (g a), ToText a) => ToText (Sum f g a) diff --git a/Z/Data/Text/Extra.hs b/Z/Data/Text/Extra.hs --- a/Z/Data/Text/Extra.hs +++ b/Z/Data/Text/Extra.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE TypeApplications #-} - {-| Module : Z.Data.Text.Extra Description : Fast text slice manipulation @@ -517,6 +510,7 @@ where tsiz = length t csiz = encodeCharLength c + go :: forall s. MutablePrimArray s Word8 -> Int -> Int -> ST s () go marr s' psiz | s' >= psiz = return () | otherwise = copyChar' csiz marr s' marr (s'-csiz) >> go marr (s'+csiz) psiz @@ -536,6 +530,7 @@ where tsiz = length t csiz = encodeCharLength c + go :: forall s. MutablePrimArray s Word8 -> Int -> Int -> ST s () go marr s' siz | s' >= siz = return () | otherwise = copyChar' csiz marr s' marr (s'-csiz) >> go marr (s'+csiz) siz diff --git a/Z/Data/Text/Search.hs b/Z/Data/Text/Search.hs --- a/Z/Data/Text/Search.hs +++ b/Z/Data/Text/Search.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} - - {-| Module : Z.Data.Text.Search Description : Searching text diff --git a/Z/Data/Text/ShowT.hs b/Z/Data/Text/ShowT.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Text/ShowT.hs @@ -0,0 +1,694 @@ +{-| +Module : Z.Data.Text.Builder +Description : UTF8 compatible builders. +Copyright : (c) Dong Han, 2017-2019 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +Base on UTF8 compatible textual builders from 'Z.Data.Builder', we provide a newtype wrapper +'TextBuilder' which can be directly used to build 'Text'. + +We also provide faster alternative to 'Show' class, i.e. 'ShowT', which also provides 'Generic' +based instances deriving. + +-} + +module Z.Data.Text.ShowT + ( -- * ShowT class + ShowT(..), showT, toBuilder, toBytes, toString + -- * Str newtype + , Str(..) + -- * Textual Builder + , TextBuilder + , getBuilder + , unsafeFromBuilder + , buildText + -- * Basic UTF8 builders + , stringUTF8, charUTF8, string7, char7, text, escapeTextJSON + -- * Numeric builders + -- ** Integral type formatting + , B.IFormat(..) + , B.defaultIFormat + , B.Padding(..) + , int + , intWith + , integer + -- ** Fixded size hexidecimal formatting + , hex, heX + -- ** IEEE float formating + , B.FFormat(..) + , double + , doubleWith + , float + , floatWith + , scientific + , scientificWith + -- * Builder helpers + , paren, parenWhen, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList + ) where + +import Control.Monad +import Control.Monad.ST.Unsafe (unsafeIOToST) +import qualified Data.Scientific as Sci +import Data.String +import Data.Bits +import Data.Fixed +import Data.Primitive.PrimArray +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.Int +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy(..)) +import Data.Ratio (Ratio, numerator, denominator) +import Data.Tagged (Tagged (..)) +import Data.Word +import qualified Data.Semigroup as Semigroup +import Data.Typeable +import Foreign.C.Types +import GHC.Exts +import GHC.Natural +import GHC.Generics +import GHC.Stack +import Data.Version +import Data.Primitive.Types +import qualified Z.Data.Builder.Base as B +import qualified Z.Data.Builder.Numeric as B +import qualified Z.Data.Text.Base as T +import Z.Data.Text.Base (Text(..)) +import qualified Z.Data.Array as A +import qualified Z.Data.Vector.Base as V +import Text.Read (Read(..)) +import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) + +#define DOUBLE_QUOTE 34 + +-- | Buidlers which guarantee UTF-8 encoding, thus can be used to build +-- text directly. +-- +-- Notes on 'IsString' instance: It's recommended to use 'IsString' instance, there's a rewrite rule to +-- turn encoding loop into a memcpy, which is much faster (the same rule also apply to 'stringUTF8'). +-- Different from @Builder ()@, @TextBuilder ()@'s 'IsString' instance will give you desired UTF8 guarantees: +-- +-- * @\NUL@ will be written directly as @\x00@. +-- +-- * @\xD800@ ~ @\xDFFF@ will be replaced by replacement char. +-- +newtype TextBuilder a = TextBuilder { getBuilder :: B.Builder a } + deriving newtype (Functor, Applicative, Monad) + +deriving newtype instance Semigroup (TextBuilder ()) +deriving newtype instance Monoid (TextBuilder ()) + +instance (a ~ ()) => IsString (TextBuilder a) where + {-# INLINE fromString #-} + fromString = TextBuilder <$> B.stringUTF8 + +instance Arbitrary (TextBuilder ()) where + arbitrary = TextBuilder . B.text <$> arbitrary + shrink b = TextBuilder . B.text <$> shrink (buildText b) + +instance CoArbitrary (TextBuilder ()) where + coarbitrary = coarbitrary . buildText + +instance Show (TextBuilder a) where + show = show . buildText + +instance ShowT (TextBuilder a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ b = quotes (void b) + +-- | Build a 'Text' using 'TextBuilder', which provide UTF-8 encoding guarantee. +buildText :: TextBuilder a -> Text +{-# INLINE buildText #-} +buildText = Text . B.buildBytes . getBuilder + +-- | Unsafely turn a 'B.Builder' into 'TextBuilder', thus it's user's responsibility to +-- ensure only UTF-8 complied bytes are written. +unsafeFromBuilder :: B.Builder a -> TextBuilder a +{-# INLINE unsafeFromBuilder #-} +unsafeFromBuilder = TextBuilder + +-------------------------------------------------------------------------------- + +-- | Turn 'String' into 'TextBuilder' with UTF8 encoding +-- +-- Illegal codepoints will be written as 'T.replacementChar's. This function will be rewritten into a memcpy if possible, (running a fast UTF-8 validation at runtime first). +stringUTF8 :: String -> TextBuilder () +{-# INLINE stringUTF8 #-} +stringUTF8 = TextBuilder . B.stringUTF8 + +-- | Turn 'Char' into 'TextBuilder' with UTF8 encoding +-- +-- Illegal codepoints will be written as 'T.replacementChar's. +charUTF8 :: Char -> TextBuilder () +{-# INLINE charUTF8 #-} +charUTF8 = TextBuilder . B.charUTF8 + +-- | Turn 'String' into 'TextBuilder' with ASCII7 encoding +-- +-- Codepoints beyond @'\x7F'@ will be chopped. +string7 :: String -> TextBuilder () +{-# INLINE string7 #-} +string7 = TextBuilder . B.string7 + +-- | Turn 'Char' into 'TextBuilder' with ASCII7 encoding +-- +-- Codepoints beyond @'\x7F'@ will be chopped. +char7 :: Char -> TextBuilder () +{-# INLINE char7 #-} +char7 = TextBuilder . B.char7 + +-- | Write UTF8 encoded 'T.Text' using 'Builder'. +-- +-- Note, if you're trying to write string literals builders, +-- please open 'OverloadedStrings' and use 'Builder's 'IsString' instance, +-- it will be rewritten into a memcpy. +text :: T.Text -> TextBuilder () +{-# INLINE text #-} +text = TextBuilder . B.text + +-------------------------------------------------------------------------------- + +-- | @int = intWith defaultIFormat@ +int :: (Integral a, Bounded a) => a -> TextBuilder () +{-# INLINE int #-} +int = TextBuilder . B.int + +-- | Format a 'Bounded' 'Integral' type like @Int@ or @Word16@ into decimal ascii digits. +intWith :: (Integral a, Bounded a) + => B.IFormat + -> a + -> TextBuilder () +{-# INLINE intWith #-} +intWith fmt x = TextBuilder $ B.intWith fmt x + +-- | Format a 'Integer' into decimal ascii digits. +integer :: Integer -> TextBuilder () +{-# INLINE integer #-} +integer = TextBuilder . B.integer + +-- | Format a 'FiniteBits' 'Integral' type into hex nibbles. +hex :: (FiniteBits a, Integral a) => a -> TextBuilder () +{-# INLINE hex #-} +hex = TextBuilder . B.hex + +-- | The UPPERCASED version of 'hex'. +heX :: (FiniteBits a, Integral a) => a -> TextBuilder () +{-# INLINE heX #-} +heX = TextBuilder . B.heX + +-- | Decimal encoding of an IEEE 'Float'. +-- +-- Using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise. +float :: Float -> TextBuilder () +{-# INLINE float #-} +float = TextBuilder . B.float + +-- | Format single-precision float using drisu3 with dragon4 fallback. +floatWith :: B.FFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Float + -> TextBuilder () +{-# INLINE floatWith #-} +floatWith fmt ds x = TextBuilder (B.floatWith fmt ds x) + + +-- | Decimal encoding of an IEEE 'Double'. +-- +-- Using standard decimal notation for arguments whose absolute value lies +-- between @0.1@ and @9,999,999@, and scientific notation otherwise. +double :: Double -> TextBuilder () +{-# INLINE double #-} +double = TextBuilder . B.double + +-- | Format double-precision float using drisu3 with dragon4 fallback. +doubleWith :: B.FFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Double + -> TextBuilder () +{-# INLINE doubleWith #-} +doubleWith fmt ds x = TextBuilder (B.doubleWith fmt ds x) + + +-- | A @Builder@ which renders a scientific number to full +-- precision, using standard decimal notation for arguments whose +-- absolute value lies between @0.1@ and @9,999,999@, and scientific +-- notation otherwise. +scientific :: Sci.Scientific -> TextBuilder () +{-# INLINE scientific #-} +scientific = TextBuilder . B.scientific + +-- | Like 'scientific' but provides rendering options. +scientificWith :: B.FFormat + -> Maybe Int -- ^ Number of decimal places to render. + -> Sci.Scientific + -> TextBuilder () +{-# INLINE scientificWith #-} +scientificWith fmt ds x = TextBuilder (B.scientificWith fmt ds x) + +-------------------------------------------------------------------------------- + +-- | add @(...)@ to original builder. +paren :: TextBuilder () -> TextBuilder () +{-# INLINE paren #-} +paren (TextBuilder b) = TextBuilder (B.paren b) + +-- | Add "(..)" around builders when condition is met, otherwise add nothing. +-- +-- This is useful when defining 'ShowT' instances. +parenWhen :: Bool -> TextBuilder () -> TextBuilder () +{-# INLINE parenWhen #-} +parenWhen True b = paren b +parenWhen _ b = b + +-- | add @{...}@ to original builder. +curly :: TextBuilder () -> TextBuilder () +{-# INLINE curly #-} +curly (TextBuilder b) = TextBuilder (B.curly b) + +-- | add @[...]@ to original builder. +square :: TextBuilder () -> TextBuilder () +{-# INLINE square #-} +square (TextBuilder b) = TextBuilder (B.square b) + +-- | add @<...>@ to original builder. +angle :: TextBuilder () -> TextBuilder () +{-# INLINE angle #-} +angle (TextBuilder b) = TextBuilder (B.angle b) + +-- | add @"..."@ to original builder. +quotes :: TextBuilder () -> TextBuilder () +{-# INLINE quotes #-} +quotes (TextBuilder b) = TextBuilder (B.quotes b) + +-- | add @'...'@ to original builder. +squotes :: TextBuilder () -> TextBuilder () +{-# INLINE squotes #-} +squotes (TextBuilder b) = TextBuilder (B.squotes b) + +-- | write an ASCII @:@ +colon :: TextBuilder () +{-# INLINE colon #-} +colon = TextBuilder B.colon + +-- | write an ASCII @,@ +comma :: TextBuilder () +{-# INLINE comma #-} +comma = TextBuilder B.comma + +-- | Use separator to connect a vector of builders. +intercalateVec :: (V.Vec v a) + => TextBuilder () -- ^ the seperator + -> (a -> TextBuilder ()) -- ^ value formatter + -> v a -- ^ value list + -> TextBuilder () +{-# INLINE intercalateVec #-} +intercalateVec (TextBuilder s) f = TextBuilder . B.intercalateVec s (getBuilder . f) + +-- | Use separator to connect a list of builders. +intercalateList :: TextBuilder () -- ^ the seperator + -> (a -> TextBuilder ()) -- ^ value formatter + -> [a] -- ^ value vector + -> TextBuilder () +{-# INLINE intercalateList #-} +intercalateList (TextBuilder s) f = TextBuilder . B.intercalateList s (getBuilder . f) + +-------------------------------------------------------------------------------- +-- | Newtype wrapper for @[Char]@ to provide textual instances. +-- +-- We didn't provide special treatment to differentiate instances between @[a]@ and @[Char]@ +-- in various classes, e.g. 'Z.Data.JSON.ToJSON'. +-- +-- This newtype is therefore to provide instances similar to @T.Text@, in case you really +-- need to wrap a 'String'. +-- +-- >>> Z.Data.JSON.encodeText ("abc" :: String) +-- > "[\"a\",\"b\",\"c\"]" -- Just like any other [a]'s instance +-- >>> Z.Data.JSON.encodeText . Str $ ("abc" :: String) +-- > "\"abc\"" +-- +newtype Str = Str { chrs :: [Char] } deriving stock (Eq, Ord, Generic) + +instance Show Str where show = show . chrs +instance Read Str where readPrec = Str <$> readPrec + +instance ShowT Str where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = TextBuilder . B.string8 . show + +-------------------------------------------------------------------------------- +-- Data types +-- +-- | A class similar to 'Show', serving the purpose that quickly convert a data type to a 'Text' value. +-- +-- You can use newtype or generic deriving to implement instance of this class quickly: +-- +-- @ +-- {-## LANGUAGE GeneralizedNewtypeDeriving ##-} +-- {-## LANGUAGE DeriveAnyClass ##-} +-- {-## LANGUAGE DeriveGeneric ##-} +-- {-## LANGUAGE DerivingStrategies ##-} +-- +-- import GHC.Generics +-- +-- newtype FooInt = FooInt Int deriving (Generic) +-- deriving anyclass ShowT +-- +-- > showT (FooInt 3) +-- > "FooInt 3" +-- +-- newtype FooInt = FooInt Int deriving (Generic) +-- deriving newtype ShowT +-- +-- > showT (FooInt 3) +-- > "3" +-- @ +-- +class ShowT a where + toTextBuilder :: Int -> a -> TextBuilder () + default toTextBuilder :: (Generic a, GToText (Rep a)) => Int -> a -> TextBuilder () + toTextBuilder p = gToTextBuilder p . from + +class GToText f where + gToTextBuilder :: Int -> f a -> TextBuilder () + + +class GFieldToText f where + gFieldToTextBuilder :: B.Builder () -> Int -> f a -> B.Builder () + +instance (GFieldToText a, GFieldToText b) => GFieldToText (a :*: b) where + {-# INLINE gFieldToTextBuilder #-} + gFieldToTextBuilder sep p (a :*: b) = + gFieldToTextBuilder sep p a >> sep >> gFieldToTextBuilder sep p b + +instance (GToText f) => GFieldToText (S1 (MetaSel Nothing u ss ds) f) where + {-# INLINE gFieldToTextBuilder #-} + gFieldToTextBuilder _ p (M1 x) = getBuilder (gToTextBuilder p x) + +instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where + {-# INLINE gFieldToTextBuilder #-} + gFieldToTextBuilder _ _ m1@(M1 x) = + B.stringModifiedUTF8 (selName m1) >> " = " >> getBuilder (gToTextBuilder 0 x) + +instance GToText V1 where + {-# INLINE gToTextBuilder #-} + gToTextBuilder _ = error "Z.Data.TextBuilder: empty data type" + +instance (GToText f, GToText g) => GToText (f :+: g) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder p (L1 x) = gToTextBuilder p x + gToTextBuilder p (R1 x) = gToTextBuilder p x + +-- | Constructor without payload, convert to String +instance (Constructor c) => GToText (C1 c U1) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder _ m1 = + TextBuilder . B.stringModifiedUTF8 $ conName m1 + +-- | Constructor with payloads +instance (GFieldToText (S1 sc f), Constructor c) => GToText (C1 c (S1 sc f)) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder p m1@(M1 x) = + parenWhen (p > 10) . TextBuilder $ do + B.stringModifiedUTF8 $ conName m1 + B.char8 ' ' + if conIsRecord m1 + then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x + else gFieldToTextBuilder (B.char7 ' ') 11 x + +instance (GFieldToText (a :*: b), Constructor c) => GToText (C1 c (a :*: b)) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder p m1@(M1 x) = + case conFixity m1 of + Prefix -> parenWhen (p > 10) . TextBuilder $ do + B.stringModifiedUTF8 $ conName m1 + B.char8 ' ' + if conIsRecord m1 + then B.curly $ gFieldToTextBuilder (B.char7 ',' >> B.char7 ' ') p x + else gFieldToTextBuilder (B.char7 ' ') 11 x + Infix _ p' -> parenWhen (p > p') . TextBuilder $ do + gFieldToTextBuilder + (B.char8 ' ' >> B.stringModifiedUTF8 (conName m1) >> B.char8 ' ') (p'+1) x + +instance ShowT a => GToText (K1 i a) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder p (K1 x) = toTextBuilder p x + +-------------------------------------------------------------------------------- +-- Data types +instance GToText f => GToText (D1 c f) where + {-# INLINE gToTextBuilder #-} + gToTextBuilder p (M1 x) = gToTextBuilder p x + +-- | Directly convert data to 'Text'. +showT :: ShowT a => a -> Text +{-# INLINE showT #-} +showT = buildText . toTextBuilder 0 + +-- | Directly convert data to 'B.Builder'. +toBuilder :: ShowT a => a -> B.Builder () +{-# INLINE toBuilder #-} +toBuilder = getBuilder . toTextBuilder 0 + +-- | Directly convert data to 'V.Bytes'. +toBytes :: ShowT a => a -> V.Bytes +{-# INLINE toBytes #-} +toBytes = B.buildBytes . toBuilder + +-- | Faster 'show' replacement. +toString :: ShowT a => a -> String +{-# INLINE toString #-} +toString = T.unpack . showT + +instance ShowT Bool where + {-# INLINE toTextBuilder #-} + toTextBuilder _ True = TextBuilder "True" + toTextBuilder _ _ = TextBuilder "False" + +instance ShowT Char where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = TextBuilder . B.string8 . show + +instance ShowT Double where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = double;} +instance ShowT Float where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = float;} + +instance ShowT Int where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Int8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Int16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Int32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Int64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Word where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Word8 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Word16 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Word32 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} +instance ShowT Word64 where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = int;} + +instance ShowT Integer where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer;} +instance ShowT Natural where {{-# INLINE toTextBuilder #-}; toTextBuilder _ = integer . fromIntegral} +instance ShowT Ordering where + {-# INLINE toTextBuilder #-} + toTextBuilder _ GT = TextBuilder "GT" + toTextBuilder _ EQ = TextBuilder "EQ" + toTextBuilder _ _ = TextBuilder "LT" + +instance ShowT () where + {-# INLINE toTextBuilder #-} + toTextBuilder _ () = TextBuilder "()" + +instance ShowT Version where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = stringUTF8 . show + +-- | The escaping rules is same with 'Show' instance: we reuse JSON escaping rules here, so it will be faster. +instance ShowT Text where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = TextBuilder . escapeTextJSON + +-- | Escape text using JSON string escaping rules and add double quotes, escaping rules: +-- +-- @ +-- \'\\b\': \"\\b\" +-- \'\\f\': \"\\f\" +-- \'\\n\': \"\\n\" +-- \'\\r\': \"\\r\" +-- \'\\t\': \"\\t\" +-- \'\"\': \"\\\"\" +-- \'\\\': \"\\\\\" +-- \'\/\': \"\\/\" +-- other chars <= 0x1F: "\\u00XX" +-- @ +-- +escapeTextJSON :: T.Text -> B.Builder () +{-# INLINE escapeTextJSON #-} +escapeTextJSON (T.Text (V.PrimVector ba@(PrimArray ba#) s l)) = do + let siz = escape_json_string_length ba# s l + B.ensureN siz + B.Builder (\ _ k (B.Buffer mba@(MutablePrimArray mba#) i) -> do + if siz == l+2 -- no need to escape + then do + writePrimArray mba i DOUBLE_QUOTE + copyPrimArray mba (i+1) ba s l + writePrimArray mba (i+1+l) DOUBLE_QUOTE + else void $ unsafeIOToST (escape_json_string ba# s l (unsafeCoerce# mba#) i) + k () (B.Buffer mba (i+siz))) + +foreign import ccall unsafe escape_json_string_length + :: ByteArray# -> Int -> Int -> Int + +foreign import ccall unsafe escape_json_string + :: ByteArray# -> Int -> Int -> MutableByteArray# RealWorld -> Int -> IO Int + +instance ShowT Sci.Scientific where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = scientific + +instance ShowT a => ShowT [a] where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateList comma (toTextBuilder 0) + +instance ShowT a => ShowT (A.Array a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance ShowT a => ShowT (A.SmallArray a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance (A.PrimUnlifted a, ShowT a) => ShowT (A.UnliftedArray a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance (Prim a, ShowT a) => ShowT (A.PrimArray a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance ShowT a => ShowT (V.Vector a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance (Prim a, ShowT a) => ShowT (V.PrimVector a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = square . intercalateVec comma (toTextBuilder 0) + +instance (ShowT a, ShowT b) => ShowT (a, b) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + +instance (ShowT a, ShowT b, ShowT c) => ShowT (a, b, c) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b, c) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + >> comma >> toTextBuilder 0 c + +instance (ShowT a, ShowT b, ShowT c, ShowT d) => ShowT (a, b, c, d) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b, c, d) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + >> comma >> toTextBuilder 0 c + >> comma >> toTextBuilder 0 d + +instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e) => ShowT (a, b, c, d, e) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b, c, d, e) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + >> comma >> toTextBuilder 0 c + >> comma >> toTextBuilder 0 d + >> comma >> toTextBuilder 0 e + +instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e, ShowT f) => ShowT (a, b, c, d, e, f) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b, c, d, e, f) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + >> comma >> toTextBuilder 0 c + >> comma >> toTextBuilder 0 d + >> comma >> toTextBuilder 0 e + >> comma >> toTextBuilder 0 f + +instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e, ShowT f, ShowT g) => ShowT (a, b, c, d, e, f, g) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ (a, b, c, d, e, f, g) = paren $ toTextBuilder 0 a + >> comma >> toTextBuilder 0 b + >> comma >> toTextBuilder 0 c + >> comma >> toTextBuilder 0 d + >> comma >> toTextBuilder 0 e + >> comma >> toTextBuilder 0 f + >> comma >> toTextBuilder 0 g + +instance ShowT a => ShowT (Maybe a) where + {-# INLINE toTextBuilder #-} + toTextBuilder p (Just x) = parenWhen (p > 10) $ do TextBuilder "Just " + toTextBuilder 11 x + toTextBuilder _ _ = TextBuilder "Nothing" + +instance (ShowT a, ShowT b) => ShowT (Either a b) where + {-# INLINE toTextBuilder #-} + toTextBuilder p (Left x) = parenWhen (p > 10) $ do TextBuilder "Left " + toTextBuilder 11 x + toTextBuilder p (Right x) = parenWhen (p > 10) $ do TextBuilder "Right " + toTextBuilder 11 x + +instance (ShowT a, Integral a) => ShowT (Ratio a) where + {-# INLINE toTextBuilder #-} + toTextBuilder p r = parenWhen (p > 10) $ do toTextBuilder 8 (numerator r) + TextBuilder " % " + toTextBuilder 8 (denominator r) + +instance HasResolution a => ShowT (Fixed a) where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = TextBuilder . B.string8 . show + +instance ShowT CallStack where + {-# INLINE toTextBuilder #-} + toTextBuilder _ = TextBuilder . B.string8 . show + +deriving newtype instance ShowT CChar +deriving newtype instance ShowT CSChar +deriving newtype instance ShowT CUChar +deriving newtype instance ShowT CShort +deriving newtype instance ShowT CUShort +deriving newtype instance ShowT CInt +deriving newtype instance ShowT CUInt +deriving newtype instance ShowT CLong +deriving newtype instance ShowT CULong +deriving newtype instance ShowT CPtrdiff +deriving newtype instance ShowT CSize +deriving newtype instance ShowT CWchar +deriving newtype instance ShowT CSigAtomic +deriving newtype instance ShowT CLLong +deriving newtype instance ShowT CULLong +deriving newtype instance ShowT CBool +deriving newtype instance ShowT CIntPtr +deriving newtype instance ShowT CUIntPtr +deriving newtype instance ShowT CIntMax +deriving newtype instance ShowT CUIntMax +deriving newtype instance ShowT CClock +deriving newtype instance ShowT CTime +deriving newtype instance ShowT CUSeconds +deriving newtype instance ShowT CSUSeconds +deriving newtype instance ShowT CFloat +deriving newtype instance ShowT CDouble + +deriving anyclass instance ShowT a => ShowT (Semigroup.Min a) +deriving anyclass instance ShowT a => ShowT (Semigroup.Max a) +deriving anyclass instance ShowT a => ShowT (Semigroup.First a) +deriving anyclass instance ShowT a => ShowT (Semigroup.Last a) +deriving anyclass instance ShowT a => ShowT (Semigroup.WrappedMonoid a) +deriving anyclass instance ShowT a => ShowT (Semigroup.Dual a) +deriving anyclass instance ShowT a => ShowT (Monoid.First a) +deriving anyclass instance ShowT a => ShowT (Monoid.Last a) +deriving anyclass instance ShowT a => ShowT (NonEmpty a) +deriving anyclass instance ShowT a => ShowT (Identity a) +deriving anyclass instance ShowT a => ShowT (Const a b) +deriving anyclass instance ShowT (Proxy a) +deriving anyclass instance ShowT b => ShowT (Tagged a b) +deriving anyclass instance ShowT (f (g a)) => ShowT (Compose f g a) +deriving anyclass instance (ShowT (f a), ShowT (g a)) => ShowT (Product f g a) +deriving anyclass instance (ShowT (f a), ShowT (g a), ShowT a) => ShowT (Sum f g a) diff --git a/Z/Data/Text/UTF8Codec.hs b/Z/Data/Text/UTF8Codec.hs --- a/Z/Data/Text/UTF8Codec.hs +++ b/Z/Data/Text/UTF8Codec.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - {-| Module : Z.Data.Text.UTF8Codec Description : UTF-8 codecs and helpers. diff --git a/Z/Data/Text/UTF8Rewind.hsc b/Z/Data/Text/UTF8Rewind.hsc --- a/Z/Data/Text/UTF8Rewind.hsc +++ b/Z/Data/Text/UTF8Rewind.hsc @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} - {-| Module : Z.Data.Text.UTF8Rewind Description : Errno provided by libuv @@ -67,7 +63,8 @@ -- | Unicode categories. -- -- See 'Z.Data.Text.Base.isCategory', you can combine categories with bitwise or. -newtype Category = Category CSize deriving (Show, Eq, Ord, Bits, FiniteBits, Generic) +newtype Category = Category CSize deriving (Show, Eq, Ord, Generic) + deriving newtype (Bits, FiniteBits) pattern CategoryLetterUppercase :: Category pattern CategoryLetterLowercase :: Category diff --git a/Z/Data/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE CApiFFI #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - {-| Module : Z.Data.Vector Description : Fast boxed and unboxed vector diff --git a/Z/Data/Vector/Base.hs b/Z/Data/Vector/Base.hs --- a/Z/Data/Vector/Base.hs +++ b/Z/Data/Vector/Base.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE TypeApplications #-} - {-| Module : Z.Data.Vector.Base Description : Fast boxed and unboxed vector @@ -103,7 +86,6 @@ import Control.Monad.ST import Data.Bits import Data.Char (ord) -import Data.Data import qualified Data.Foldable as F import Data.Hashable (Hashable(..)) import Data.Hashable.Lifted (Hashable1(..), hashWithSalt1) @@ -203,7 +185,6 @@ {-# UNPACK #-} !(SmallArray a) -- ^ payload {-# UNPACK #-} !Int -- ^ offset {-# UNPACK #-} !Int -- ^ length - deriving (Typeable, Data) instance Vec Vector a where type IArray Vector = SmallArray @@ -395,7 +376,6 @@ {-# UNPACK #-} !(PrimArray a) -- ^ payload {-# UNPACK #-} !Int -- ^ offset in elements of type a rather than in bytes {-# UNPACK #-} !Int -- ^ length in elements of type a rather than in bytes - deriving Typeable instance Prim a => Vec PrimVector a where type IArray PrimVector = PrimArray @@ -1311,7 +1291,7 @@ -- | All exception can be throw by using 'Vec'. data VectorException = IndexOutOfVectorRange {-# UNPACK #-} !Int CallStack | EmptyVector CallStack - deriving (Show, Typeable) + deriving Show instance Exception VectorException errorEmptyVector :: HasCallStack => a diff --git a/Z/Data/Vector/Extra.hs b/Z/Data/Vector/Extra.hs --- a/Z/Data/Vector/Extra.hs +++ b/Z/Data/Vector/Extra.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE TypeApplications #-} - {-| Module : Z.Data.Vector.Extra Description : Fast vector slice manipulation @@ -597,7 +590,7 @@ -- | /O(n)/ An efficient way to join vector with an element. -- -intercalateElem :: Vec v a => a -> [v a] -> v a +intercalateElem :: forall v a. Vec v a => a -> [v a] -> v a {-# INLINE intercalateElem #-} intercalateElem _ [] = empty intercalateElem _ [v] = v @@ -606,6 +599,7 @@ len [] !acc = acc len [Vec _ _ l] !acc = l + acc len (Vec _ _ l:vs') !acc = len vs' (acc+l+1) + go :: forall s. Int -> [v a] -> MArr (IArray v) s a -> ST s () go !_ [] !_ = return () go !i (Vec arr s l:[]) !marr = copyArr marr i arr s l go !i (Vec arr s l:vs') !marr = do @@ -630,12 +624,13 @@ -- -- For example, @'zipWith' (+)@ is applied to two vector to produce -- a vector of corresponding sums, the result will be evaluated strictly. -zipWith' :: (Vec v a, Vec u b, Vec w c) +zipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c) => (a -> b -> c) -> v a -> u b -> w c {-# INLINE zipWith' #-} zipWith' f (Vec arrA sA lA) (Vec arrB sB lB) = create len (go 0) where !len = min lA lB + go :: forall s. Int -> MArr (IArray w) s c -> ST s () go !i !marr | i >= len = return () | otherwise = case indexArr' arrA (i+sA) of @@ -646,11 +641,12 @@ -- | 'unzipWith'' disassemble a vector with a disassembling function, -- -- The results inside tuple will be evaluated strictly. -unzipWith' :: (Vec v a, Vec u b, Vec w c) +unzipWith' :: forall v a u b w c. (Vec v a, Vec u b, Vec w c) => (a -> (b, c)) -> v a -> (u b, w c) {-# INLINE unzipWith' #-} unzipWith' f (Vec arr s l) = createN2 l l (go 0) where + go :: forall s. Int -> MArr (IArray u) s b -> MArr (IArray w) s c -> ST s (Int, Int) go !i !marrB !marrC | i >= l = return (l,l) | otherwise = case indexArr' arr (i+s) of diff --git a/Z/Data/Vector/FlatIntMap.hs b/Z/Data/Vector/FlatIntMap.hs --- a/Z/Data/Vector/FlatIntMap.hs +++ b/Z/Data/Vector/FlatIntMap.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - {-| Module : Z.Data.Vector.FlatIntMap Description : Fast int map based on sorted vector @@ -50,7 +41,7 @@ import qualified Data.Primitive.SmallArray as A import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Sort as V -import qualified Z.Data.Text.Builder as T +import qualified Z.Data.Text.ShowT as T import Data.Function (on) import Data.Bits (shiftR) import Data.Data @@ -62,7 +53,7 @@ newtype FlatIntMap v = FlatIntMap { sortedKeyValues :: V.Vector (V.IPair v) } deriving (Show, Eq, Ord, Typeable) -instance T.ToText v => T.ToText (FlatIntMap v) where +instance T.ShowT v => T.ShowT (FlatIntMap v) where {-# INLINE toTextBuilder #-} toTextBuilder p (FlatIntMap vec) = T.parenWhen (p > 10) $ do T.unsafeFromBuilder "FlatIntMap {" diff --git a/Z/Data/Vector/FlatIntSet.hs b/Z/Data/Vector/FlatIntSet.hs --- a/Z/Data/Vector/FlatIntSet.hs +++ b/Z/Data/Vector/FlatIntSet.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - {-| Module : Z.Data.Vector.FlatIntSet Description : Fast int set based on sorted vector @@ -45,7 +35,7 @@ import qualified Data.Primitive.PrimArray as A import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Sort as V -import qualified Z.Data.Text.Builder as T +import qualified Z.Data.Text.ShowT as T import Data.Bits (shiftR) import Data.Data import Prelude hiding (elem, null) @@ -54,9 +44,9 @@ -------------------------------------------------------------------------------- newtype FlatIntSet = FlatIntSet { sortedValues :: V.PrimVector Int } - deriving (Show, Eq, Ord, Typeable, NFData) + deriving (Show, Eq, Ord, Typeable) -instance T.ToText FlatIntSet where +instance T.ShowT FlatIntSet where {-# INLINE toTextBuilder #-} toTextBuilder p (FlatIntSet vec) = T.parenWhen (p > 10) $ do T.unsafeFromBuilder "FlatIntSet {" @@ -72,6 +62,10 @@ mappend = merge {-# INLINE mempty #-} mempty = empty + +instance NFData FlatIntSet where + {-# INLINE rnf #-} + rnf (FlatIntSet vs) = rnf vs instance Arbitrary FlatIntSet where arbitrary = pack <$> arbitrary diff --git a/Z/Data/Vector/FlatMap.hs b/Z/Data/Vector/FlatMap.hs --- a/Z/Data/Vector/FlatMap.hs +++ b/Z/Data/Vector/FlatMap.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Data.Vector.FlatMap Description : Fast map based on sorted vector @@ -51,7 +41,7 @@ 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.Text.Builder as T +import qualified Z.Data.Text.ShowT as T import Data.Function (on) import Data.Bits (shiftR) import Data.Data @@ -63,7 +53,7 @@ newtype FlatMap k v = FlatMap { sortedKeyValues :: V.Vector (k, v) } deriving (Show, Eq, Ord, Typeable) -instance (T.ToText k, T.ToText v) => T.ToText (FlatMap k v) where +instance (T.ShowT k, T.ShowT v) => T.ShowT (FlatMap k v) where {-# INLINE toTextBuilder #-} toTextBuilder p (FlatMap vec) = T.parenWhen (p > 10) $ do T.unsafeFromBuilder "FlatMap {" diff --git a/Z/Data/Vector/FlatSet.hs b/Z/Data/Vector/FlatSet.hs --- a/Z/Data/Vector/FlatSet.hs +++ b/Z/Data/Vector/FlatSet.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Data.Vector.FlatSet Description : Fast set based on sorted vector @@ -44,9 +33,9 @@ import qualified Data.Primitive.SmallArray as A 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.Text.Builder as T +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Sort as V +import qualified Z.Data.Text.ShowT as T import Data.Bits (shiftR) import Data.Data import Prelude hiding (elem, null) @@ -55,9 +44,9 @@ -------------------------------------------------------------------------------- newtype FlatSet v = FlatSet { sortedValues :: V.Vector v } - deriving (Show, Eq, Ord, Typeable, Foldable, NFData) + deriving (Show, Eq, Ord, Typeable, Foldable) -instance T.ToText v => T.ToText (FlatSet v) where +instance T.ShowT v => T.ShowT (FlatSet v) where {-# INLINE toTextBuilder #-} toTextBuilder p (FlatSet vec) = T.parenWhen (p > 10) $ do T.unsafeFromBuilder "FlatSet {" @@ -73,6 +62,10 @@ mappend = merge {-# INLINE mempty #-} mempty = empty + +instance NFData v => NFData (FlatSet v) where + {-# INLINE rnf #-} + rnf (FlatSet vs) = rnf vs instance (Ord v, Arbitrary v) => Arbitrary (FlatSet v) where arbitrary = pack <$> arbitrary diff --git a/Z/Data/Vector/QQ.hs b/Z/Data/Vector/QQ.hs --- a/Z/Data/Vector/QQ.hs +++ b/Z/Data/Vector/QQ.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MagicHash #-} - {-| Module : Z.Data.Vector.QQ Description : vectors literals using QuasiQuote diff --git a/Z/Data/Vector/Search.hs b/Z/Data/Vector/Search.hs --- a/Z/Data/Vector/Search.hs +++ b/Z/Data/Vector/Search.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Data.Vector.Search Description : Searching vectors diff --git a/Z/Data/Vector/Sort.hs b/Z/Data/Vector/Sort.hs --- a/Z/Data/Vector/Sort.hs +++ b/Z/Data/Vector/Sort.hs @@ -1,14 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} - {-| Module : Z.Data.Vector.Sort Description : Sorting vectors @@ -68,6 +57,7 @@ import Data.Word import Prelude hiding (splitAt) import Z.Data.Array +import Z.Data.Array.Unaligned import Z.Data.Vector.Base import Z.Data.Vector.Extra @@ -97,6 +87,8 @@ w <- mergePass w1 w2 mergeTileSize return $! fromArr w 0 l) where + firstPass :: forall s. v a -> Int -> MArr (IArray v) s a -> ST s () + {-# INLINABLE firstPass #-} firstPass !v !i !marr | i >= l = return () | otherwise = do @@ -104,12 +96,16 @@ insertSortToMArr cmp v' i marr firstPass rest (i+mergeTileSize) marr + mergePass :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> ST s (IArray v a) + {-# INLINABLE mergePass #-} mergePass !w1 !w2 !blockSiz | blockSiz >= l = unsafeFreezeArr w1 | otherwise = do mergeLoop w1 w2 blockSiz 0 mergePass w2 w1 (blockSiz*2) -- swap worker array and continue merging + mergeLoop :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> Int -> ST s () + {-# INLINABLE mergeLoop #-} mergeLoop !src !target !blockSiz !i | i >= l-blockSiz = -- remaining elements less than a block if i >= l @@ -120,6 +116,8 @@ mergeBlock src target (i+blockSiz) mergeEnd i (i+blockSiz) i mergeLoop src target blockSiz mergeEnd + mergeBlock :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> Int -> Int -> Int -> Int -> Int -> ST s () + {-# INLINABLE mergeBlock #-} mergeBlock !src !target !leftEnd !rightEnd !i !j !k = do lv <- readArr src i rv <- readArr src j @@ -263,7 +261,8 @@ -- | Similar to 'Down' newtype for 'Ord', this newtype can inverse the order of a 'Radix' -- instance when used in 'radixSort'. -newtype RadixDown a = RadixDown a deriving (Show, Eq, Prim) +newtype RadixDown a = RadixDown a deriving (Show, Eq) + deriving newtype (Prim, Unaligned) instance Radix a => Radix (RadixDown a) where {-# INLINE bucketSize #-} @@ -293,14 +292,14 @@ | l <= 1 = v | otherwise = runST (do bucket <- newArrWith buktSiz 0 :: ST s (MutablePrimArray s Int) - w1 <- newArr l + w1 <- newArr l :: ST s (MArr (IArray v) s a) firstCountPass arr bucket s accumBucket bucket buktSiz 0 0 firstMovePass arr s bucket w1 w <- if passSiz == 1 then unsafeFreezeArr w1 else do - w2 <- newArr l + w2 <- newArr l :: ST s (MArr (IArray v) s a) radixLoop w1 w2 bucket buktSiz 1 return $! fromArr w 0 l) where @@ -309,6 +308,7 @@ !end = s + l {-# INLINABLE firstCountPass #-} + firstCountPass :: forall s. IArray v a -> MutablePrimArray s Int -> Int -> ST s () firstCountPass !arr' !bucket !i | i >= end = return () | otherwise = case indexArr' arr' i of @@ -319,6 +319,7 @@ firstCountPass arr' bucket (i+1) {-# INLINABLE accumBucket #-} + accumBucket :: forall s. MutablePrimArray s Int -> Int -> Int -> Int -> ST s () accumBucket !bucket !bsiz !i !acc | i >= bsiz = return () | otherwise = do @@ -327,6 +328,7 @@ accumBucket bucket bsiz (i+1) (acc+c) {-# INLINABLE firstMovePass #-} + firstMovePass :: forall s. IArray v a -> Int -> MutablePrimArray s Int -> MArr (IArray v) s a -> ST s () firstMovePass !arr' !i !bucket !w | i >= end = return () | otherwise = case indexArr' arr' i of @@ -338,6 +340,7 @@ firstMovePass arr' (i+1) bucket w {-# INLINABLE radixLoop #-} + radixLoop :: forall s. MArr (IArray v) s a -> MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> Int -> ST s ((IArray v) a) radixLoop !w1 !w2 !bucket !bsiz !pass | pass >= passSiz-1 = do setArr bucket 0 bsiz 0 -- clear the counting bucket @@ -353,6 +356,7 @@ radixLoop w2 w1 bucket bsiz (pass+1) {-# INLINABLE countPass #-} + countPass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> Int -> ST s () countPass !marr !bucket !pass !i | i >= l = return () | otherwise = do @@ -363,6 +367,7 @@ countPass marr bucket pass (i+1) {-# INLINABLE movePass #-} + movePass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> MArr (IArray v) s a -> Int -> ST s () movePass !src !bucket !pass !target !i | i >= l = return () | otherwise = do @@ -374,6 +379,7 @@ movePass src bucket pass target (i+1) {-# INLINABLE lastCountPass #-} + lastCountPass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> Int -> ST s () lastCountPass !marr !bucket !i | i >= l = return () | otherwise = do @@ -384,6 +390,7 @@ lastCountPass marr bucket (i+1) {-# INLINABLE lastMovePass #-} + lastMovePass :: forall s. MArr (IArray v) s a -> MutablePrimArray s Int -> MArr (IArray v) s a -> Int -> ST s () lastMovePass !src !bucket !target !i | i >= l = return () | otherwise = do @@ -449,12 +456,12 @@ -- | merge duplicated adjacent element, prefer left element. -- -- Use this function on a sorted vector will have the same effects as 'nub'. -mergeDupAdjacent :: (Vec v a, Eq a) => v a -> v a +mergeDupAdjacent :: forall v a. (Vec v a, Eq a) => v a -> v a {-# INLINE mergeDupAdjacent #-} mergeDupAdjacent = mergeDupAdjacentBy (==) const -- | Merge duplicated adjacent element, prefer left element. -mergeDupAdjacentLeft :: Vec v a +mergeDupAdjacentLeft :: forall v a. Vec v a => (a -> a -> Bool) -- ^ equality tester, @\ left right -> eq left right@ -> v a -> v a @@ -462,7 +469,7 @@ {-# INLINE mergeDupAdjacentLeft #-} -- | Merge duplicated adjacent element, prefer right element. -mergeDupAdjacentRight :: Vec v a +mergeDupAdjacentRight :: forall v a. Vec v a => (a -> a -> Bool) -- ^ equality tester, @\ left right -> eq left right@ -> v a -> v a @@ -470,7 +477,7 @@ mergeDupAdjacentRight eq = mergeDupAdjacentBy eq (\ _ x -> x) -- | Merge duplicated adjacent element, based on a equality tester and a merger function. -mergeDupAdjacentBy :: Vec v a +mergeDupAdjacentBy :: forall v a. Vec v a => (a -> a -> Bool) -- ^ equality tester, @\ left right -> eq left right@ -> (a -> a -> a) -- ^ the merger, @\ left right -> merge left right@ -> v a -> v a @@ -484,6 +491,7 @@ go arr marr s 1 x0 where !end = s + l + go :: forall s. IArray v a -> MArr (IArray v) s a -> Int -> Int -> a -> ST s Int go !arr' !marr !i !j !x | i >= end = return j | otherwise = do diff --git a/Z/Foreign.hs b/Z/Foreign.hs --- a/Z/Foreign.hs +++ b/Z/Foreign.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - {-| Module : Z.Foreign Description : Use PrimArray with FFI diff --git a/test/Z/Data/Text/BuilderSpec.hs b/test/Z/Data/Text/BuilderSpec.hs deleted file mode 100644 --- a/test/Z/Data/Text/BuilderSpec.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module Z.Data.Text.BuilderSpec where - -import qualified Data.List as L -import Data.Word -import Data.Int -import GHC.Generics -import qualified Z.Data.Text as T -import Z.Data.Text.Builder -import Z.Data.JSON (Value) -import Test.QuickCheck -import Test.QuickCheck.Function -import Test.QuickCheck.Property -import Test.Hspec -import Test.Hspec.QuickCheck - - -data T a - = Nullary - | Unary Int - | Product T.Text (Maybe Char) a - | Record { testOne :: Double - , testTwo :: Maybe Bool - , testThree :: Maybe a - } - | List [a] - deriving (Show, Eq, ToText, Generic) - -data I a = I a :+ I a | I a :- I a | J a deriving (Show, Generic, ToText) -infixr 5 :+ -infixl 6 :- - -spec :: Spec -spec = describe "JSON Base instances" $ do - - it "Nullary constructor are encoded as text" $ - toText (Nullary :: T Integer) === "Nullary" - - it "Unary constructor are encoded as single field" $ - toText (Unary 123456 :: T Integer) === "Unary 123456" - - it "Product are encoded as multiple field" $ - toText (Product "ABC" (Just 'x') (123456::Integer)) === - "Product \"ABC\" (Just 'x') 123456" - - it "Record are encoded as key values" $ - toText (Record 0.123456 Nothing (Just (123456::Integer))) === - "Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}" - - it "List are encode as array" $ - toText (List [Nullary - , Unary 123456 - , (Product "ABC" (Just 'x') (123456::Integer)) - , (Record 0.123456 Nothing (Just (123456::Integer)))]) === - "List [Nullary,Unary 123456,Product \"ABC\" (Just 'x') 123456,\ - \Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}]" - - it "infix constructor should respect piority" $ - toString (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11 :: I Int) - === show (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11) - - prop "Value Show instance === ToText instances" $ \ (v :: Value) -> - toString v === show v diff --git a/test/Z/Data/Text/ExtraSpec.hs b/test/Z/Data/Text/ExtraSpec.hs --- a/test/Z/Data/Text/ExtraSpec.hs +++ b/test/Z/Data/Text/ExtraSpec.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Z.Data.Text.ExtraSpec where import qualified Data.List as List diff --git a/test/Z/Data/Text/SearchSpec.hs b/test/Z/Data/Text/SearchSpec.hs --- a/test/Z/Data/Text/SearchSpec.hs +++ b/test/Z/Data/Text/SearchSpec.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Z.Data.Text.SearchSpec where import qualified Data.List as List diff --git a/test/Z/Data/Text/ShowTSpec.hs b/test/Z/Data/Text/ShowTSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Text/ShowTSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Z.Data.Text.ShowTSpec where + +import qualified Data.List as L +import Data.Word +import Data.Int +import GHC.Generics +import qualified Z.Data.Text as T +import Z.Data.Text.ShowT +import Z.Data.JSON (Value) +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.Hspec +import Test.Hspec.QuickCheck + + +data T a + = Nullary + | Unary Int + | Product T.Text (Maybe Char) a + | Record { testOne :: Double + , testTwo :: Maybe Bool + , testThree :: Maybe a + } + | List [a] + deriving (Show, Eq, ShowT, Generic) + +data I a = I a :+ I a | I a :- I a | J a deriving (Show, Generic, ShowT) +infixr 5 :+ +infixl 6 :- + +spec :: Spec +spec = describe "JSON Base instances" $ do + + it "Nullary constructor are encoded as text" $ + showT (Nullary :: T Integer) === "Nullary" + + it "Unary constructor are encoded as single field" $ + showT (Unary 123456 :: T Integer) === "Unary 123456" + + it "Product are encoded as multiple field" $ + showT (Product "ABC" (Just 'x') (123456::Integer)) === + "Product \"ABC\" (Just 'x') 123456" + + it "Record are encoded as key values" $ + showT (Record 0.123456 Nothing (Just (123456::Integer))) === + "Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}" + + it "List are encode as array" $ + showT (List [Nullary + , Unary 123456 + , (Product "ABC" (Just 'x') (123456::Integer)) + , (Record 0.123456 Nothing (Just (123456::Integer)))]) === + "List [Nullary,Unary 123456,Product \"ABC\" (Just 'x') 123456,\ + \Record {testOne = 0.123456, testTwo = Nothing, testThree = Just 123456}]" + + it "infix constructor should respect piority" $ + toString (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11 :: I Int) + === show (J 1 :- J 2 :+ J 3 :- J 4 :- J 5 :+ J 6 :+ J 7 :+ J 8 :- J 9 :- J 10 :- J 11) + + prop "Value Show instance === ToText instances" $ \ (v :: Value) -> + toString v === show v