diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Revision history for Z-Data +## 0.3.0.0 -- 2020-12-29 + +* Hide `Text` constructor from `Z.Data.Text`. +* Add `fromStdString` to `Z.Data.CBytes`. +* Re-export `touch` from `Z.Foreign`, export `ConvertError` constructor from `Z.Data.JSON`. +* Add `anyChar8` to `Z.Data.Parser`. +* Add `Z.Data.ASCII`, move `c2w`, `w2c`, `isDigit`, `isSpace`, `isHexDigit` and ASCII constants to it. +* Rename `ShowT` class to `Print`, re-export from `Z.Data.Text` module. +* Add various JSON instances of types from `time` package, add `Z.Data.Builder.Time` and `Z.Data.Parser.Time`. +* Fix a bug affecting comparing `PrimVector`s. + ## 0.2.0.0 -- 2020-12-15 * Add `Z.Data.Text.Regex` module, which provide regex functions using RE2. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ ([],Right (Array [Number 1.0,Number 2.0,Number 3.0,Number 4.0,Number 5.0])) > > -- JSON module support deriving through Generic -> set -XDeriveAnyClass -XDeriveGeneric +> :set -XDeriveAnyClass -XDeriveGeneric > data Foo = Foo {foo :: Double} deriving (JSON.FromValue, JSON.ToValue, JSON.EncodeJSON, Generic) > JSON.toValue (Foo 0.01) Object [("foo",Number 1.0e-2)] 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.2.0.0 +version: 0.3.0.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -129,6 +129,7 @@ Z.Data.Array.QQ Z.Data.Array.Unaligned Z.Data.Array.UnliftedArray + Z.Data.ASCII Z.Data.CBytes Z.Data.Vector Z.Data.Vector.Base @@ -148,7 +149,7 @@ Z.Data.Text.Extra Z.Data.Text.Regex Z.Data.Text.Search - Z.Data.Text.ShowT + Z.Data.Text.Print Z.Data.Text.UTF8Codec Z.Data.Text.UTF8Rewind @@ -156,12 +157,14 @@ Z.Data.Builder.Base Z.Data.Builder.Numeric Z.Data.Builder.Numeric.DigitTable + Z.Data.Builder.Time Z.Data.Generics.Utils Z.Data.Parser Z.Data.Parser.Base Z.Data.Parser.Numeric + Z.Data.Parser.Time Z.Data.PrimRef Z.Data.PrimRef.PrimSTRef @@ -172,6 +175,7 @@ Z.Data.JSON.Builder Z.Data.JSON.Value + Z.Foreign build-depends: base >= 4.12 && <5.0 @@ -182,9 +186,10 @@ , case-insensitive == 1.2.* , deepseq >= 1.4 && < 1.5 , QuickCheck >= 2.10 + , tagged == 0.8.* , template-haskell >= 2.14.0 + , time >= 1.9 && < 2.0 , unordered-containers == 0.2.* - , tagged == 0.8.* if os(windows) extra-libraries: stdc++ @@ -321,15 +326,17 @@ build-tool-depends: hsc2hs:hsc2hs, hspec-discover:hspec-discover other-modules: Z.Data.CBytesSpec Z.Data.Builder.NumericSpec + Z.Data.Builder.TimeSpec Z.Data.JSON.BaseSpec Z.Data.JSON.ValueSpec Z.Data.Parser.BaseSpec Z.Data.Parser.NumericSpec + Z.Data.Parser.TimeSpec Z.Data.Array.UnalignedSpec Z.Data.Text.BaseSpec Z.Data.Text.ExtraSpec Z.Data.Text.SearchSpec - Z.Data.Text.ShowTSpec + Z.Data.Text.PrintSpec Z.Data.Vector.BaseSpec Z.Data.Vector.ExtraSpec Z.Data.Vector.SearchSpec @@ -347,9 +354,9 @@ , HUnit , QuickCheck >= 2.10 , quickcheck-instances - , word8 , scientific , primitive + , time c-sources: test/cbits/ffi.c diff --git a/Z/Data/ASCII.hs b/Z/Data/ASCII.hs new file mode 100644 --- /dev/null +++ b/Z/Data/ASCII.hs @@ -0,0 +1,343 @@ +module Z.Data.ASCII where + +import GHC.Word +import GHC.Exts + +-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. +-- +w2c :: Word8 -> Char +{-# INLINE w2c #-} +w2c (W8# w#) = C# (chr# (word2Int# w#)) + +-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and +-- silently truncates to 8 bits Chars > @\\255@. +c2w :: Char -> Word8 +{-# INLINE c2w #-} +c2w (C# c#) = W8# (int2Word# (ord# c#)) + +-- | @\\NUL <= w && w <= \\DEL@ +isASCII :: Word8 -> Bool +{-# INLINE isASCII #-} +isASCII w = w <= DEL + +-- | @A ~ Z@ +isUpper :: Word8 -> Bool +{-# INLINE isUpper #-} +isUpper w = w - LETTER_A <= 25 + +-- | @a ~ z@ +isLower :: Word8 -> Bool +{-# INLINE isLower #-} +isLower w = w - LETTER_a <= 25 + +-- | @ISO-8859-1@ control letter. +isControl :: Word8 -> Bool +{-# INLINE isControl #-} +isControl w = w <= 0x1f || w - DEL <= 32 + +-- | @ISO-8859-1@ space letter. +isSpace :: Word8 -> Bool +{-# INLINE isSpace #-} +isSpace w = w == SPACE || w - TAB <= 4 || w == 0xa0 + +-- | @0 ~ 9@ +isDigit :: Word8 -> Bool +{-# INLINE isDigit #-} +isDigit w = w - DIGIT_0 <= 9 + +-- | @0 ~ 7@ +isOctDigit :: Word8 -> Bool +{-# INLINE isOctDigit #-} +isOctDigit w = w - DIGIT_0 <= 7 + +-- | @0 ~ 9, A ~ F, a ~ f@ +isHexDigit :: Word8 -> Bool +{-# INLINE isHexDigit #-} +isHexDigit w = w - DIGIT_0 <= 9 || w - LETTER_A <= 5 || w - LETTER_a <= 5 + +---------------------------------------------------------------- + +-- | @\\NUL@ +pattern NUL :: Word8 +pattern NUL = 0x00 +-- | @\\t@ +pattern TAB :: Word8 +pattern TAB = 0x09 +-- | @\\n@ +pattern NEWLINE :: Word8 +pattern NEWLINE = 0x0a +-- | @\\v@ +pattern VERTICAL_TAB :: Word8 +pattern VERTICAL_TAB = 0x0b +-- | @\\f@ +pattern FORM_FEED :: Word8 +pattern FORM_FEED = 0x0c +-- | @\\r@ +pattern CARRIAGE_RETURN :: Word8 +pattern CARRIAGE_RETURN = 0x0d + +-- | @\' \'@ +pattern SPACE :: Word8 +pattern SPACE = 0x20 +-- | @\!@ +pattern EXCLAM :: Word8 +pattern EXCLAM = 0x21 +-- | @\"@ +pattern QUOTE_DOUBLE :: Word8 +pattern QUOTE_DOUBLE = 0x22 +-- | @\#@ +pattern HASH :: Word8 +pattern HASH = 0x23 +-- | @\#@ +pattern NUMBER_SIGN :: Word8 +pattern NUMBER_SIGN = 0x23 +-- | @\$@ +pattern DOLLAR :: Word8 +pattern DOLLAR = 0x24 +-- | @\%@ +pattern PERCENT :: Word8 +pattern PERCENT = 0x25 +-- | @\&@ +pattern AMPERSAND :: Word8 +pattern AMPERSAND = 0x26 +-- | @\&@ +pattern AND :: Word8 +pattern AND = 0x26 +-- | @\'@ +pattern QUOTE_SINGLE :: Word8 +pattern QUOTE_SINGLE = 0x27 +-- | @(@ +pattern PAREN_LEFT :: Word8 +pattern PAREN_LEFT = 0x28 +-- | @)@ +pattern PAREN_RIGHT :: Word8 +pattern PAREN_RIGHT = 0x29 +-- | @*@ +pattern ASTERISK :: Word8 +pattern ASTERISK = 0x2a +-- | @+@ +pattern PLUS :: Word8 +pattern PLUS = 0x2b +-- | @,@ +pattern COMMA :: Word8 +pattern COMMA = 0x2c +-- | @-@ +pattern HYPHEN :: Word8 +pattern HYPHEN = 0x2d +-- | @-@ +pattern MINUS :: Word8 +pattern MINUS = 0x2d +-- | @.@ +pattern PERIOD :: Word8 +pattern PERIOD = 0x2e +-- | @.@ +pattern DOT :: Word8 +pattern DOT = 0x2e +-- | @\/@ +pattern SLASH :: Word8 +pattern SLASH = 0x2f + +pattern DIGIT_0 :: Word8 +pattern DIGIT_0 = 0x30 +pattern DIGIT_1 :: Word8 +pattern DIGIT_1 = 0x31 +pattern DIGIT_2 :: Word8 +pattern DIGIT_2 = 0x32 +pattern DIGIT_3 :: Word8 +pattern DIGIT_3 = 0x33 +pattern DIGIT_4 :: Word8 +pattern DIGIT_4 = 0x34 +pattern DIGIT_5 :: Word8 +pattern DIGIT_5 = 0x35 +pattern DIGIT_6 :: Word8 +pattern DIGIT_6 = 0x36 +pattern DIGIT_7 :: Word8 +pattern DIGIT_7 = 0x37 +pattern DIGIT_8 :: Word8 +pattern DIGIT_8 = 0x38 +pattern DIGIT_9 :: Word8 +pattern DIGIT_9 = 0x39 + +-- | @:@ +pattern COLON :: Word8 +pattern COLON = 0x3a +-- | @;@ +pattern SEMICOLON :: Word8 +pattern SEMICOLON = 0x3b +-- | @<@ +pattern LESS :: Word8 +pattern LESS = 0x3c +-- | @<@ +pattern ANGLE_LEFT :: Word8 +pattern ANGLE_LEFT = 0x3c +-- | @=@ +pattern EQUAL :: Word8 +pattern EQUAL = 0x3d +-- | @>@ +pattern GREATER :: Word8 +pattern GREATER = 0x3e +-- | @>@ +pattern ANGLE_RIGHT :: Word8 +pattern ANGLE_RIGHT = 0x3e +-- | @\?@ +pattern QUESTION :: Word8 +pattern QUESTION = 0x3f +-- | @\@@ +pattern AT :: Word8 +pattern AT = 0x40 + +pattern LETTER_A :: Word8 +pattern LETTER_A = 0x41 +pattern LETTER_B :: Word8 +pattern LETTER_B = 0x42 +pattern LETTER_C :: Word8 +pattern LETTER_C = 0x43 +pattern LETTER_D :: Word8 +pattern LETTER_D = 0x44 +pattern LETTER_E :: Word8 +pattern LETTER_E = 0x45 +pattern LETTER_F :: Word8 +pattern LETTER_F = 0x46 +pattern LETTER_G :: Word8 +pattern LETTER_G = 0x47 +pattern LETTER_H :: Word8 +pattern LETTER_H = 0x48 +pattern LETTER_I :: Word8 +pattern LETTER_I = 0x49 +pattern LETTER_J :: Word8 +pattern LETTER_J = 0x4a +pattern LETTER_K :: Word8 +pattern LETTER_K = 0x4b +pattern LETTER_L :: Word8 +pattern LETTER_L = 0x4c +pattern LETTER_M :: Word8 +pattern LETTER_M = 0x4d +pattern LETTER_N :: Word8 +pattern LETTER_N = 0x4e +pattern LETTER_O :: Word8 +pattern LETTER_O = 0x4f +pattern LETTER_P :: Word8 +pattern LETTER_P = 0x50 +pattern LETTER_Q :: Word8 +pattern LETTER_Q = 0x51 +pattern LETTER_R :: Word8 +pattern LETTER_R = 0x52 +pattern LETTER_S :: Word8 +pattern LETTER_S = 0x53 +pattern LETTER_T :: Word8 +pattern LETTER_T = 0x54 +pattern LETTER_U :: Word8 +pattern LETTER_U = 0x55 +pattern LETTER_V :: Word8 +pattern LETTER_V = 0x56 +pattern LETTER_W :: Word8 +pattern LETTER_W = 0x57 +pattern LETTER_X :: Word8 +pattern LETTER_X = 0x58 +pattern LETTER_Y :: Word8 +pattern LETTER_Y = 0x59 +pattern LETTER_Z :: Word8 +pattern LETTER_Z = 0x5a + +-- | @[@ +pattern BRACKET_LEFT :: Word8 +pattern BRACKET_LEFT = 0x5b +-- | @[@ +pattern SQUARE_LEFT :: Word8 +pattern SQUARE_LEFT = 0x5b +-- | @\\@ +pattern BACKSLASH :: Word8 +pattern BACKSLASH = 0x5c +-- | @]@ +pattern BRACKET_RIGHT :: Word8 +pattern BRACKET_RIGHT = 0x5d +-- | @]@ +pattern SQUARE_RIGHT :: Word8 +pattern SQUARE_RIGHT = 0x5d +-- | @^@ +pattern CIRCUM :: Word8 +pattern CIRCUM = 0x5e +-- | @_@ +pattern UNDERSCORE :: Word8 +pattern UNDERSCORE = 0x5f +-- | @`@ +pattern GRAVE :: Word8 +pattern GRAVE = 0x60 + +pattern LETTER_a :: Word8 +pattern LETTER_a = 0x61 +pattern LETTER_b :: Word8 +pattern LETTER_b = 0x62 +pattern LETTER_c :: Word8 +pattern LETTER_c = 0x63 +pattern LETTER_d :: Word8 +pattern LETTER_d = 0x64 +pattern LETTER_e :: Word8 +pattern LETTER_e = 0x65 +pattern LETTER_f :: Word8 +pattern LETTER_f = 0x66 +pattern LETTER_g :: Word8 +pattern LETTER_g = 0x67 +pattern LETTER_h :: Word8 +pattern LETTER_h = 0x68 +pattern LETTER_i :: Word8 +pattern LETTER_i = 0x69 +pattern LETTER_j :: Word8 +pattern LETTER_j = 0x6a +pattern LETTER_k :: Word8 +pattern LETTER_k = 0x6b +pattern LETTER_l :: Word8 +pattern LETTER_l = 0x6c +pattern LETTER_m :: Word8 +pattern LETTER_m = 0x6d +pattern LETTER_n :: Word8 +pattern LETTER_n = 0x6e +pattern LETTER_o :: Word8 +pattern LETTER_o = 0x6f +pattern LETTER_p :: Word8 +pattern LETTER_p = 0x70 +pattern LETTER_q :: Word8 +pattern LETTER_q = 0x71 +pattern LETTER_r :: Word8 +pattern LETTER_r = 0x72 +pattern LETTER_s :: Word8 +pattern LETTER_s = 0x73 +pattern LETTER_t :: Word8 +pattern LETTER_t = 0x74 +pattern LETTER_u :: Word8 +pattern LETTER_u = 0x75 +pattern LETTER_v :: Word8 +pattern LETTER_v = 0x76 +pattern LETTER_w :: Word8 +pattern LETTER_w = 0x77 +pattern LETTER_x :: Word8 +pattern LETTER_x = 0x78 +pattern LETTER_y :: Word8 +pattern LETTER_y = 0x79 +pattern LETTER_z :: Word8 +pattern LETTER_z = 0x7a + +-- | @{@ +pattern BRACE_LEFT :: Word8 +pattern BRACE_LEFT = 0x7b +-- | @{@ +pattern CURLY_LEFT :: Word8 +pattern CURLY_LEFT = 0x7b +-- | @|@ +pattern BAR :: Word8 +pattern BAR = 0x7c +-- | @|@ +pattern OR :: Word8 +pattern OR = 0x7c +-- | @}@ +pattern BRACE_RIGHT :: Word8 +pattern BRACE_RIGHT = 0x7d +-- | @}@ +pattern CURLY_RIGHT :: Word8 +pattern CURLY_RIGHT = 0x7d +-- | @~@ +pattern TILDE :: Word8 +pattern TILDE = 0x7e +-- | @\\DEL@ +pattern DEL :: Word8 +pattern DEL = 0x7f 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 @@ -18,6 +18,7 @@ import Data.Primitive.ByteArray import Data.Primitive.PrimArray import GHC.Int +import GHC.IO import GHC.Exts import GHC.Word import GHC.Float (stgFloatToWord32, stgWord32ToFloat, stgWord64ToDouble, stgDoubleToWord64) @@ -31,6 +32,9 @@ -------------------------------------------------------------------------------- +newtype UnalignedSize a = UnalignedSize { getUnalignedSize :: Int } deriving (Show, Eq, Ord) + deriving newtype Num + -- | Primitive types which can be unaligned accessed -- -- It can also be used as a lightweight method to peek\/poke value from\/to C structs @@ -50,18 +54,12 @@ -- @ -- class Unaligned a where - {-# MINIMAL (unalignedSize# | unalignedSize), + {-# MINIMAL unalignedSize, (indexWord8ArrayAs# | indexBA), (writeWord8ArrayAs# | peekMBA), (readWord8ArrayAs# | pokeMBA) #-} -- | byte size - unalignedSize :: a -> Int - {-# INLINE unalignedSize #-} - unalignedSize a = I# (unalignedSize# a) - - unalignedSize# :: a -> Int# - {-# INLINE unalignedSize# #-} - unalignedSize# a = case unalignedSize a of I# siz_a# -> siz_a# + unalignedSize :: UnalignedSize a -- | index element off byte array with offset in bytes(maybe unaligned) indexWord8ArrayAs# :: ByteArray# -> Int# -> a @@ -72,13 +70,14 @@ readWord8ArrayAs# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) {-# INLINE readWord8ArrayAs# #-} readWord8ArrayAs# mba# i# s# = - (unsafeCoerce# (peekMBA (unsafeCoerce# mba#) (I# i#) :: IO a)) s# + unsafeCoerce# (peekMBA (unsafeCoerce# mba#) (I# i#) :: IO a) s# -- | write element to byte array with offset in bytes(maybe unaligned) writeWord8ArrayAs# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# x s# = - unsafeCoerce# (pokeMBA (unsafeCoerce# mba#) (I# i#) x) s# + let !(# s'#, _ #) = unIO (pokeMBA (unsafeCoerce# mba#) (I# i#) x :: IO ()) (unsafeCoerce# s#) + in unsafeCoerce# s'# -- | IO version of 'writeWord8ArrayAs#' but more convenient to write manually. peekMBA :: MutableByteArray# RealWorld -> Int -> IO a @@ -128,7 +127,7 @@ instance Unaligned Word8 where {-# INLINE unalignedSize #-} - unalignedSize _ = 1 + unalignedSize = UnalignedSize 1 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (W8# x#) = writeWord8Array# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -139,7 +138,7 @@ instance Unaligned Int8 where {-# INLINE unalignedSize #-} - unalignedSize _ = 1 + unalignedSize = UnalignedSize 1 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (I8# x#) = writeInt8Array# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -169,7 +168,7 @@ instance Unaligned Word16 where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (W16# x#) = writeWord8ArrayAsWord16# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -180,7 +179,7 @@ instance Unaligned (LE Word16) where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (W16# x#)) s0# = @@ -202,7 +201,7 @@ instance Unaligned (BE Word16) where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -239,7 +238,7 @@ instance Unaligned Word32 where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (W32# x#) = writeWord8ArrayAsWord32# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -251,7 +250,7 @@ instance Unaligned (LE Word32) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (W32# x#)) s0# = @@ -283,7 +282,7 @@ instance Unaligned (BE Word32) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -330,7 +329,7 @@ instance Unaligned Word64 where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (W64# x#) = writeWord8ArrayAsWord64# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -342,7 +341,7 @@ instance Unaligned (LE Word64) where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (W64# x#)) s0# = @@ -394,7 +393,7 @@ instance Unaligned (BE Word64) where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -462,10 +461,10 @@ instance Unaligned Word where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #endif {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (W# x#) = writeWord8ArrayAsWord# mba# i# x# @@ -478,7 +477,7 @@ instance Unaligned (LE Word) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W32# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -488,7 +487,7 @@ indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W32# x#)) -> LE (W# x#) #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W64# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -501,7 +500,7 @@ instance Unaligned (BE Word) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W32# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -511,7 +510,7 @@ indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W32# x#)) -> BE (W# x#) #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W64# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -525,7 +524,7 @@ instance Unaligned Int16 where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (I16# x#) = writeWord8ArrayAsInt16# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -536,7 +535,7 @@ instance Unaligned (LE Int16) where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (I16# x#)) = @@ -555,7 +554,7 @@ instance Unaligned (BE Int16) where {-# INLINE unalignedSize #-} - unalignedSize _ = 2 + unalignedSize = UnalignedSize 2 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -576,7 +575,7 @@ instance Unaligned Int32 where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (I32# x#) = writeWord8ArrayAsInt32# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -587,7 +586,7 @@ instance Unaligned (LE Int32) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (I32# x#)) = @@ -606,7 +605,7 @@ instance Unaligned (BE Int32) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -627,7 +626,7 @@ instance Unaligned Int64 where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (I64# x#) = writeWord8ArrayAsInt64# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -638,7 +637,7 @@ instance Unaligned (LE Int64) where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (I64# x#)) = @@ -657,7 +656,7 @@ instance Unaligned (BE Int64) where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -679,10 +678,10 @@ instance Unaligned Int where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #endif {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (I# x#) = writeWord8ArrayAsInt# mba# i# x# @@ -695,7 +694,7 @@ instance Unaligned (LE Int) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I32# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -705,7 +704,7 @@ indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I32# x#)) -> LE (I# x#) #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I64# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -718,7 +717,7 @@ instance Unaligned (BE Int) where #if SIZEOF_HSWORD == 4 {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I32# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -728,7 +727,7 @@ indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I32# x#)) -> BE (I# x#) #else {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I64# x#)) {-# INLINE readWord8ArrayAs# #-} @@ -742,7 +741,7 @@ instance Unaligned (Ptr a) where {-# INLINE unalignedSize #-} - unalignedSize _ = SIZEOF_HSPTR + unalignedSize = UnalignedSize SIZEOF_HSPTR {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (Ptr x#) = writeWord8ArrayAsAddr# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -753,7 +752,7 @@ instance Unaligned Float where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (F# x#) = writeWord8ArrayAsFloat# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -764,7 +763,7 @@ instance Unaligned (LE Float) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (F# x#)) = @@ -783,7 +782,7 @@ instance Unaligned (BE Float) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -804,7 +803,7 @@ instance Unaligned Double where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (D# x#) = writeWord8ArrayAsDouble# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -815,7 +814,7 @@ instance Unaligned (LE Double) where {-# INLINE unalignedSize #-} - unalignedSize _ = 8 + unalignedSize = UnalignedSize 8 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (D# x#)) = @@ -834,7 +833,7 @@ instance Unaligned (BE Double) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -856,7 +855,7 @@ -- | Char's instance use 31bit wide char prim-op. instance Unaligned Char where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (C# x#) = writeWord8ArrayAsWideChar# mba# i# x# {-# INLINE readWord8ArrayAs# #-} @@ -867,7 +866,7 @@ instance Unaligned (LE Char) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) {-# INLINE writeWord8ArrayAs# #-} writeWord8ArrayAs# mba# i# (LE (C# x#)) = @@ -886,7 +885,7 @@ instance Unaligned (BE Char) where {-# INLINE unalignedSize #-} - unalignedSize _ = 4 + unalignedSize = UnalignedSize 4 #if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) USE_HOST_IMPL(BE) #else @@ -903,46 +902,365 @@ in BE (C# (chr# x#)) #endif -{- not really useful +-- | Write a, b in order instance (Unaligned a, Unaligned b) => Unaligned (a, b) where {-# INLINE unalignedSize #-} - unalignedSize (a, b) = unalignedSize a + unalignedSize b - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (a, b) s0 = - let s1 = writeWord8ArrayAs# mba# i# a s0 - in writeWord8ArrayAs# mba# (i# +# unalignedSize# a) b s1 - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, a #) = readWord8ArrayAs# mba# i# s0 - !(# s2, b #) = readWord8ArrayAs# mba# (i# +# unalignedSize# a) s1 - in (# s2, (a, b) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let a = indexWord8ArrayAs# ba# i# - b = indexWord8ArrayAs# ba# (i# +# unalignedSize# a) + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b) = do + pokeMBA mba# i a + pokeMBA mba# j b + where + j = i + getUnalignedSize (unalignedSize @a) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + return (a, b) + where + j = i + getUnalignedSize (unalignedSize @a) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j in (a, b) + where + j = i + getUnalignedSize (unalignedSize @a) +-- | Write a, b, c in order instance (Unaligned a, Unaligned b, Unaligned c) => Unaligned (a, b, c) where {-# INLINE unalignedSize #-} - unalignedSize (a, b, c) = unalignedSize a + unalignedSize b + unalignedSize c - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (a, b, c) s0 = - let s1 = writeWord8ArrayAs# mba# i# a s0 - s2 = writeWord8ArrayAs# mba# (i# +# unalignedSize# a) b s1 - in writeWord8ArrayAs# mba# (i# +# unalignedSize# a +# unalignedSize# b) c s2 - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, a #) = readWord8ArrayAs# mba# i# s0 - !(# s2, b #) = readWord8ArrayAs# mba# (i# +# unalignedSize# a) s1 - !(# s3, c #) = readWord8ArrayAs# mba# (i# +# unalignedSize# a +# unalignedSize# b) s2 - in (# s3, (a, b, c) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let a = indexWord8ArrayAs# ba# i# - b = indexWord8ArrayAs# ba# (i# +# unalignedSize# a) - c = indexWord8ArrayAs# ba# (i# +# unalignedSize# a +# unalignedSize# b) + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + return (a, b, c) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k in (a, b, c) --} + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + +-- | Write a, b, c, d in order +instance (Unaligned a, Unaligned b, Unaligned c, Unaligned d) => Unaligned (a, b, c, d) where + {-# INLINE unalignedSize #-} + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + + getUnalignedSize (unalignedSize @d) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c, d) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + pokeMBA mba# l d + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + !d <- peekMBA mba# l + return (a, b, c, d) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k + !d = indexBA ba# l + in (a, b, c, d) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + +-- | Write a, b, c, d, e in order +instance (Unaligned a, Unaligned b, Unaligned c, Unaligned d, Unaligned e) => Unaligned (a, b, c, d, e) where + {-# INLINE unalignedSize #-} + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + + getUnalignedSize (unalignedSize @d) + + getUnalignedSize (unalignedSize @e) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c, d, e) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + pokeMBA mba# l d + pokeMBA mba# m e + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + !d <- peekMBA mba# l + !e <- peekMBA mba# m + return (a, b, c, d, e) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k + !d = indexBA ba# l + !e = indexBA ba# m + in (a, b, c, d, e) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + + +-- | Write a, b, c, d, e, f in order +instance (Unaligned a, Unaligned b, Unaligned c, Unaligned d, Unaligned e, Unaligned f) => Unaligned (a, b, c, d, e, f) where + {-# INLINE unalignedSize #-} + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + + getUnalignedSize (unalignedSize @d) + + getUnalignedSize (unalignedSize @e) + + getUnalignedSize (unalignedSize @f) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c, d, e, f) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + pokeMBA mba# l d + pokeMBA mba# m e + pokeMBA mba# n f + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + !d <- peekMBA mba# l + !e <- peekMBA mba# m + !f <- peekMBA mba# n + return (a, b, c, d, e, f) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k + !d = indexBA ba# l + !e = indexBA ba# m + !f = indexBA ba# n + in (a, b, c, d, e, f) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + +-- | Write a, b, c, d, e, f, g in order +instance (Unaligned a, Unaligned b, Unaligned c, Unaligned d, Unaligned e, Unaligned f, Unaligned g) => Unaligned (a, b, c, d, e, f, g) where + {-# INLINE unalignedSize #-} + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + + getUnalignedSize (unalignedSize @d) + + getUnalignedSize (unalignedSize @e) + + getUnalignedSize (unalignedSize @f) + + getUnalignedSize (unalignedSize @g) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c, d, e, f, g) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + pokeMBA mba# l d + pokeMBA mba# m e + pokeMBA mba# n f + pokeMBA mba# o g + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + !d <- peekMBA mba# l + !e <- peekMBA mba# m + !f <- peekMBA mba# n + !g <- peekMBA mba# o + return (a, b, c, d, e, f, g) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k + !d = indexBA ba# l + !e = indexBA ba# m + !f = indexBA ba# n + !g = indexBA ba# o + in (a, b, c, d, e, f, g) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + + +-- | Write a, b, c, d, e, f, g, h in order +instance (Unaligned a, Unaligned b, Unaligned c, Unaligned d, Unaligned e, Unaligned f, Unaligned g, Unaligned h) => Unaligned (a, b, c, d, e, f, g, h) where + {-# INLINE unalignedSize #-} + unalignedSize = + UnalignedSize ( getUnalignedSize (unalignedSize @a) + + getUnalignedSize (unalignedSize @b) + + getUnalignedSize (unalignedSize @c) + + getUnalignedSize (unalignedSize @d) + + getUnalignedSize (unalignedSize @e) + + getUnalignedSize (unalignedSize @f) + + getUnalignedSize (unalignedSize @g) + + getUnalignedSize (unalignedSize @h) + ) + {-# INLINE pokeMBA #-} + pokeMBA mba# i (a, b, c, d, e, f, g, h) = do + pokeMBA mba# i a + pokeMBA mba# j b + pokeMBA mba# k c + pokeMBA mba# l d + pokeMBA mba# m e + pokeMBA mba# n f + pokeMBA mba# o g + pokeMBA mba# p h + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + p = o + getUnalignedSize (unalignedSize @g) + + {-# INLINE peekMBA #-} + peekMBA mba# i = do + !a <- peekMBA mba# i + !b <- peekMBA mba# j + !c <- peekMBA mba# k + !d <- peekMBA mba# l + !e <- peekMBA mba# m + !f <- peekMBA mba# n + !g <- peekMBA mba# o + !h <- peekMBA mba# p + return (a, b, c, d, e, f, g, h) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + p = o + getUnalignedSize (unalignedSize @g) + + {-# INLINE indexBA #-} + indexBA ba# i = + let !a = indexBA ba# i + !b = indexBA ba# j + !c = indexBA ba# k + !d = indexBA ba# l + !e = indexBA ba# m + !f = indexBA ba# n + !g = indexBA ba# o + !h = indexBA ba# p + in (a, b, c, d, e, f, g, h) + where + j = i + getUnalignedSize (unalignedSize @a) + k = j + getUnalignedSize (unalignedSize @b) + l = k + getUnalignedSize (unalignedSize @c) + m = l + getUnalignedSize (unalignedSize @d) + n = m + getUnalignedSize (unalignedSize @e) + o = n + getUnalignedSize (unalignedSize @f) + p = o + getUnalignedSize (unalignedSize @g) + -------------------------------------------------------------------------------- -- Prim instances for newtypes in Foreign.C.Types diff --git a/Z/Data/Builder.hs b/Z/Data/Builder.hs --- a/Z/Data/Builder.hs +++ b/Z/Data/Builder.hs @@ -33,7 +33,7 @@ , encodePrimLE , encodePrimBE -- * More builders - , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, string8, char8, text + , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, word7, string8, char8, word8, text -- * Numeric builders -- ** Integral type formatting , IFormat(..) @@ -52,17 +52,17 @@ , floatWith , scientific , scientificWith - -- * Patterns - , pattern PLUS - , pattern MINUS - , pattern ZERO - , pattern SPACE - , pattern DOT - , pattern LITTLE_E - , pattern BIG_E -- * Builder helpers , paren, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList + -- * Time + , day + , timeOfDay + , timeZone + , utcTime + , localTime + , zonedTime ) where import Z.Data.Builder.Base import Z.Data.Builder.Numeric +import Z.Data.Builder.Time 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 @@ -45,7 +45,7 @@ , encodePrimLE , encodePrimBE -- * More builders - , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, string8, char8, text + , stringModifiedUTF8, charModifiedUTF8, stringUTF8, charUTF8, string7, char7, word7, string8, char8, word8, text -- * Builder helpers , paren, curly, square, angle, quotes, squotes, colon, comma, intercalateVec, intercalateList ) where @@ -60,6 +60,7 @@ import GHC.Stack import Data.Primitive.PrimArray import Z.Data.Array.Unaligned +import Z.Data.ASCII import qualified Z.Data.Text.Base as T import qualified Z.Data.Text.UTF8Codec as T import qualified Z.Data.Vector.Base as V @@ -287,8 +288,8 @@ else do vs <- unsafeInterleaveIO . loop =<< k (Buffer buf' 0) return (v':v:vs) - + -------------------------------------------------------------------------------- ensureN :: Int -- ^ size bound @@ -330,7 +331,7 @@ encodePrim x = do writeN n (\ mpa i -> writePrimWord8ArrayAs mpa i x) where - n = unalignedSize (undefined :: a) + n = getUnalignedSize (unalignedSize @a) -- | Write a primitive type with little endianess. encodePrimLE :: forall a. Unaligned (LE a) => a -> Builder () @@ -416,9 +417,16 @@ -- Codepoints beyond @'\x7F'@ will be chopped. char7 :: Char -> Builder () {-# INLINE char7 #-} -char7 chr = do - writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (V.c2w chr .&. 0x7F)) +char7 chr = + writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr .&. 0x7F)) +-- | Turn 'Word8' into 'Builder' with ASCII7 encoding +-- +-- Codepoints beyond @'\x7F'@ will be chopped. +word7 :: Word8 -> Builder () +{-# INLINE word7 #-} +word7 w = writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (w .&. 0x7F)) + -- | Turn 'String' into 'Builder' with ASCII8 encoding -- -- Codepoints beyond @'\xFF'@ will be chopped. @@ -436,8 +444,16 @@ char8 :: Char -> Builder () {-# INLINE char8 #-} char8 chr = do - writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (V.c2w chr)) + writeN 1 (\ mpa i -> writePrimWord8ArrayAs mpa i (c2w chr)) +-- | Turn 'Word8' into 'Builder' with ASCII8 encoding, (alias to 'encodePrim'). +-- +-- Note, this encoding is NOT compatible with UTF8 encoding, i.e. bytes written +-- by this builder may not be legal UTF8 encoding bytes. +word8 :: Word8 -> Builder () +{-# INLINE word8 #-} +word8 = encodePrim + -- | Write UTF8 encoded 'Text' using 'Builder'. -- -- Note, if you're trying to write string literals builders, @@ -449,59 +465,46 @@ -------------------------------------------------------------------------------- -#define BACKSLASH 92 -#define CLOSE_ANGLE 62 -#define CLOSE_CURLY 125 -#define CLOSE_PAREN 41 -#define CLOSE_SQUARE 93 -#define COMMA 44 -#define COLON 58 -#define DOUBLE_QUOTE 34 -#define OPEN_ANGLE 60 -#define OPEN_CURLY 123 -#define OPEN_PAREN 40 -#define OPEN_SQUARE 91 -#define SINGLE_QUOTE 39 -- | add @(...)@ to original builder. paren :: Builder () -> Builder () {-# INLINE paren #-} -paren b = encodePrim @Word8 OPEN_PAREN >> b >> encodePrim @Word8 CLOSE_PAREN +paren b = encodePrim PAREN_LEFT >> b >> encodePrim PAREN_RIGHT -- | add @{...}@ to original builder. curly :: Builder () -> Builder () {-# INLINE curly #-} -curly b = encodePrim @Word8 OPEN_CURLY >> b >> encodePrim @Word8 CLOSE_CURLY +curly b = encodePrim CURLY_LEFT >> b >> encodePrim CURLY_RIGHT -- | add @[...]@ to original builder. square :: Builder () -> Builder () {-# INLINE square #-} -square b = encodePrim @Word8 OPEN_SQUARE >> b >> encodePrim @Word8 CLOSE_SQUARE +square b = encodePrim SQUARE_LEFT >> b >> encodePrim SQUARE_RIGHT -- | add @/<.../>@ to original builder. angle :: Builder () -> Builder () {-# INLINE angle #-} -angle b = encodePrim @Word8 OPEN_ANGLE >> b >> encodePrim @Word8 CLOSE_ANGLE +angle b = encodePrim ANGLE_LEFT >> b >> encodePrim ANGLE_RIGHT -- | add @/".../"@ to original builder. quotes :: Builder () -> Builder () {-# INLINE quotes #-} -quotes b = encodePrim @Word8 DOUBLE_QUOTE >> b >> encodePrim @Word8 DOUBLE_QUOTE +quotes b = encodePrim QUOTE_DOUBLE >> b >> encodePrim QUOTE_DOUBLE -- | add @/'.../'@ to original builder. squotes :: Builder () -> Builder () {-# INLINE squotes #-} -squotes b = encodePrim @Word8 SINGLE_QUOTE >> b >> encodePrim @Word8 SINGLE_QUOTE +squotes b = encodePrim QUOTE_SINGLE >> b >> encodePrim QUOTE_SINGLE -- | write an ASCII @:@ colon :: Builder () {-# INLINE colon #-} -colon = encodePrim @Word8 COLON +colon = encodePrim COLON -- | write an ASCII @,@ comma :: Builder () {-# INLINE comma #-} -comma = encodePrim @Word8 COMMA +comma = encodePrim COMMA -- | Use separator to connect a vector of builders. -- 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 @@ -30,14 +30,6 @@ , floatWith , scientific , scientificWith - -- * Patterns - , pattern PLUS - , pattern MINUS - , pattern ZERO - , pattern SPACE - , pattern DOT - , pattern LITTLE_E - , pattern BIG_E -- * Misc , grisu3 , grisu3_sp @@ -57,6 +49,7 @@ import GHC.Exts import GHC.Float import GHC.Integer +import Z.Data.ASCII import Z.Data.Builder.Base import Z.Data.Builder.Numeric.DigitTable import Z.Foreign @@ -87,6 +80,7 @@ -- | @defaultIFormat = IFormat 0 NoPadding False@ defaultIFormat :: IFormat +{-# INLINE defaultIFormat #-} defaultIFormat = IFormat 0 NoPadding False data Padding = NoPadding | RightSpacePadding | LeftSpacePadding | ZeroPadding deriving (Show, Eq, Ord, Enum) @@ -182,7 +176,7 @@ let !leadingN = width-n' writePrimArray marr off MINUS -- leading MINUS let off' = off + 1 - setPrimArray marr off' leadingN ZERO -- leading zeros + setPrimArray marr off' leadingN DIGIT_0 -- leading zeros let off'' = off' + leadingN writePositiveDec marr off'' n qq -- digits let off''' = off'' + n @@ -230,7 +224,7 @@ let !leadingN = width-n' writePrimArray marr off MINUS -- leading MINUS let off' = off + 1 - setPrimArray marr off' leadingN ZERO -- leading zeros + setPrimArray marr off' leadingN DIGIT_0 -- leading zeros let off'' = off' + leadingN writePositiveDec marr off'' n qq -- digits LeftSpacePadding -> @@ -275,7 +269,7 @@ let !leadingN = width-n' writePrimArray marr off PLUS -- leading PLUS let off' = off + 1 - setPrimArray marr off' leadingN ZERO -- leading zeros + setPrimArray marr off' leadingN DIGIT_0 -- leading zeros let off'' = off' + leadingN writePositiveDec marr off'' n i -- digits LeftSpacePadding -> @@ -308,7 +302,7 @@ ZeroPadding -> writeN width $ \marr off -> do let !leadingN = width-n - setPrimArray marr off leadingN ZERO -- leading zeros + setPrimArray marr off leadingN DIGIT_0 -- leading zeros let off' = off + leadingN writePositiveDec marr off' n i -- digits LeftSpacePadding -> @@ -369,6 +363,7 @@ -- | Format a 'Integer' into decimal ASCII digits. integer :: Integer -> Builder () +{-# INLINE integer #-} #ifdef INTEGER_GMP integer (S# i#) = int (I# i#) #endif @@ -413,7 +408,7 @@ -- Split n into digits in base p. We first split n into digits -- in base p*p and then split each of these digits into two. - -- Note that the first 'digit' modulo p*p may have a leading ZERO + -- Note that the first 'digit' modulo p*p may have a leading DIGIT_0 -- in base p that we need to drop - this is what jsplith takes care of. -- jsplitb the handles the remaining digits. jsplitf :: Integer -> Integer -> [Integer] @@ -465,27 +460,18 @@ | otherwise = go (k + 12) (v `quot` 1000000000000) fin v n = if v >= n then 1 else 0 -pattern MINUS, PLUS, ZERO, SPACE, DOT, LITTLE_E, BIG_E :: Word8 -pattern PLUS = 43 -pattern MINUS = 45 -pattern ZERO = 48 -pattern SPACE = 32 -pattern DOT = 46 -pattern LITTLE_E = 101 -pattern BIG_E = 69 - -- | Decimal digit to ASCII digit. i2wDec :: (Integral a) => a -> Word8 {-# INLINE i2wDec #-} {-# SPECIALIZE INLINE i2wDec :: Int -> Word8 #-} -i2wDec v = ZERO + fromIntegral v +i2wDec v = DIGIT_0 + fromIntegral v -- | Hexadecimal digit to ASCII char. i2wHex :: (Integral a) => a -> Word8 {-# INLINE i2wHex #-} {-# SPECIALIZE INLINE i2wHex :: Int -> Word8 #-} i2wHex v - | v <= 9 = ZERO + fromIntegral v + | v <= 9 = DIGIT_0 + fromIntegral v | otherwise = 87 + fromIntegral v -- fromEnum 'a' - 10 -- | Hexadecimal digit to UPPERCASED ASCII char. @@ -493,7 +479,7 @@ {-# INLINE i2wHexUpper #-} {-# SPECIALIZE INLINE i2wHexUpper :: Int -> Word8 #-} i2wHexUpper v - | v <= 9 = ZERO + fromIntegral v + | v <= 9 = DIGIT_0 + fromIntegral v | otherwise = 55 + fromIntegral v -- fromEnum 'A' - 10 -------------------------------------------------------------------------------- @@ -656,7 +642,7 @@ encodeDigit i encodePrim DOT encodeDigits is' - encodePrim LITTLE_E + encodePrim LETTER_e int (e-1) [] -> error "doFmt/Exponent: []" Just dec @@ -670,7 +656,7 @@ let (ei,is') = roundTo 10 1 is n:_ = if ei > 0 then List.init is' else is' encodeDigit n - encodePrim LITTLE_E + encodePrim LETTER_e int (e-1+ei) Just dec -> let !dec' = max dec 1 in @@ -683,7 +669,7 @@ encodeDigit d encodePrim DOT encodeDigits ds' - encodePrim LITTLE_E + encodePrim LETTER_e int (e-1+ei) Fixed -> case decs of Nothing @@ -710,13 +696,13 @@ encodeDigits = mapM_ encodeDigit - encodeZeros n = replicateM_ n (encodePrim ZERO) + encodeZeros n = replicateM_ n (encodePrim DIGIT_0) - mk0 [] = encodePrim ZERO + mk0 [] = encodePrim DIGIT_0 mk0 ls = encodeDigits ls insertDot 0 rs = encodePrim DOT >> mk0 rs - insertDot n [] = encodePrim ZERO >> insertDot (n-1) [] + insertDot n [] = encodePrim DIGIT_0 >> insertDot (n-1) [] insertDot n (r:rs) = encodeDigit r >> insertDot (n-1) rs ------------------------------------------------------------------------------ diff --git a/Z/Data/Builder/Time.hs b/Z/Data/Builder/Time.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Builder/Time.hs @@ -0,0 +1,141 @@ +{-| +Module: Z.Data.Parser.Time +Description : Builders for types from time. +Copyright: (c) 2015-2016 Bryan O'Sullivan + (c) 2020 Dong Han +License: BSD3 +Maintainer: Dong +Stability: experimental +Portability: portable + +Builders for dates and times. +-} + +module Z.Data.Builder.Time + ( day + , timeOfDay + , timeZone + , utcTime + , localTime + , zonedTime + ) where + +import Control.Monad +import Data.Time +import Data.Word +import Data.Fixed +import Data.Int +import Z.Data.Builder.Base (Builder) +import qualified Z.Data.Builder.Base as B +import qualified Z.Data.Builder.Numeric as B +import Z.Data.Builder.Numeric (i2wDec) +import Z.Data.ASCII + +-- | @YYYY-mm-dd@. +day :: Day -> Builder () +{-# INLINE day #-} +day dd = encodeYear yr <> + B.encodePrim (HYPHEN, mh, ml, HYPHEN, dh, dl) + where (yr, m, d) = toGregorian dd + (mh, ml) = twoDigits m + (dh, dl) = twoDigits d + encodeYear y + | y >= 1000 = B.integer y + | y >= 0 = B.encodePrim (padYear y) + | y >= -999 = B.encodePrim (MINUS, padYear y) + | otherwise = B.integer y + padYear y = + let (ab,c) = (fromIntegral y :: Int) `quotRem` 10 + (a, b) = ab `quotRem` 10 + in (DIGIT_0, i2wDec a, i2wDec b, i2wDec c) + +-- | @HH-MM-SS@. +timeOfDay :: TimeOfDay -> Builder () +{-# INLINE timeOfDay #-} +timeOfDay t = timeOfDay64 (toTimeOfDay64 t) + +-- | Timezone format in @+HH:MM@, with single letter @Z@ for @+00:00@. +timeZone :: TimeZone -> Builder () +{-# INLINE timeZone #-} +timeZone (TimeZone off _ _) + | off == 0 = B.word8 LETTER_Z + | otherwise = B.encodePrim (s, hh, hl, COLON, mh, ml) + where !s = if off < 0 then MINUS else PLUS + (hh, hl) = twoDigits h + (mh, ml) = twoDigits m + (h,m) = abs off `quotRem` 60 + +-- | Write 'UTCTime' in ISO8061 @YYYY-MM-DDTHH:MM:SS.SSSZ@(time zone will always be @Z@). +utcTime :: UTCTime -> Builder () +{-# INLINE utcTime #-} +utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) >> B.word8 LETTER_Z + +-- | Write 'LocalTime' in ISO8061 @YYYY-MM-DDTHH:MM:SS.SSS@. +localTime :: LocalTime -> Builder () +{-# INLINE localTime #-} +localTime (LocalTime d t) = dayTime d (toTimeOfDay64 t) + +-- | Write 'ZonedTime' in ISO8061 @YYYY-MM-DD HH:MM:SS.SSSZ@. +zonedTime :: ZonedTime -> Builder () +{-# INLINE zonedTime #-} +zonedTime (ZonedTime t z) = localTime t >> timeZone z + +-------------------------------------------------------------------------------- + +-- | Like TimeOfDay, but using a fixed-width integer for seconds. +type TimeOfDay64 = (Int, Int, Int64) + +diffTimeOfDay64 :: DiffTime -> TimeOfDay64 +{-# INLINE diffTimeOfDay64 #-} +diffTimeOfDay64 t + | t >= 86400 = (23, 59, 60000000000000 + pico (t - 86400)) + | otherwise = (fromIntegral h, fromIntegral m, s) + where (h,mp) = pico t `quotRem` 3600000000000000 + (m,s) = mp `quotRem` 60000000000000 + pico = fromIntegral . diffTimeToPicoseconds + +toTimeOfDay64 :: TimeOfDay -> TimeOfDay64 +{-# INLINE toTimeOfDay64 #-} +toTimeOfDay64 (TimeOfDay h m (MkFixed s)) = (h, m, fromIntegral s) + +dayTime :: Day -> TimeOfDay64 -> Builder () +{-# INLINE dayTime #-} +dayTime d t = day d >> B.word8 LETTER_T >> timeOfDay64 t + +timeOfDay64 :: TimeOfDay64 -> Builder () +{-# INLINE timeOfDay64 #-} +timeOfDay64 (!h, !m, !s) = do + B.encodePrim (hh, hl, COLON, mh, ml, COLON, sh, sl) + when (frac /= 0) $ do + B.encodePrim DOT + replicateM_ (12 - n1) (B.word8 DIGIT_0) + forM_ ds (B.word8 . B.i2wDec) + where + (real, frac) = s `quotRem` 1000000000000 -- number of picoseconds in 1 second + + (hh, hl) = twoDigits h + (mh, ml) = twoDigits m + (sh, sl) = twoDigits (fromIntegral real) + + (frac', n0) = ctz frac 0 + (ds, n1) = toDigits frac' [] n0 + + ctz :: Int64 -> Int -> (Int64, Int) + ctz !x !n = + let (x', r) = x `quotRem` 10 + in if r == 0 + then ctz x' (n+1) + else (x, n) + + toDigits :: Int64 -> [Int64] -> Int -> ([Int64], Int) + toDigits !x !acc !n = + let (x', r) = x `quotRem` 10 + in if x' == 0 + then ((r:acc), n+1) + else toDigits x' (r:acc) (n+1) + +twoDigits :: Int -> (Word8, Word8) +{-# INLINE twoDigits #-} +twoDigits a = (i2wDec hi, i2wDec lo) + where (hi,lo) = a `quotRem` 10 + diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -21,22 +21,23 @@ , unpack , null, length , empty, singleton, append, concat, intercalate, intercalateElem - , fromCString, fromCStringN + , fromCString, fromCStringN, fromStdString , withCBytesUnsafe, withCBytes, allocCBytesUnsafe, allocCBytes , withCBytesListUnsafe, withCBytesList + , pokeMBACBytes, peekMBACBytes, indexBACBytes -- * re-export , CString - , V.c2w, V.w2c ) where import Control.DeepSeq import Control.Monad +import Control.Exception import Control.Monad.Primitive import Control.Monad.ST import Data.Bits -import Data.Foldable (foldlM) -import Data.Hashable (Hashable(..)) -import qualified Data.List as List +import Data.Foldable (foldlM) +import Data.Hashable (Hashable(..)) +import qualified Data.List as List import Data.Primitive.PrimArray import Data.Word import Foreign.C.String @@ -44,30 +45,29 @@ import GHC.CString import GHC.Ptr import GHC.Stack -import Prelude hiding (all, any, appendFile, break, - concat, concatMap, drop, dropWhile, - elem, filter, foldl, foldl1, foldr, - foldr1, getContents, getLine, head, - init, interact, last, length, lines, - map, maximum, minimum, notElem, null, - putStr, putStrLn, readFile, replicate, - reverse, scanl, scanl1, scanr, scanr1, - span, splitAt, tail, take, takeWhile, - unlines, unzip, writeFile, zip, - zipWith) +import Prelude hiding (all, any, appendFile, break, + concat, concatMap, drop, dropWhile, + elem, filter, foldl, foldl1, foldr, + foldr1, getContents, getLine, head, + init, interact, last, length, lines, + map, maximum, minimum, notElem, null, + putStr, putStrLn, readFile, replicate, + reverse, scanl, scanl1, scanr, scanr1, + span, splitAt, tail, take, takeWhile, + unlines, unzip, writeFile, zip, + 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 qualified Z.Data.Text.UTF8Codec as T -import qualified Z.Data.JSON.Base as JSON -import Z.Data.JSON.Base (()) -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(..)) +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T +import qualified Z.Data.Text.Print as T +import qualified Z.Data.Text.UTF8Codec as T +import qualified Z.Data.JSON.Base as JSON +import Z.Data.JSON.Base (()) +import Z.Data.Text.UTF8Codec (encodeCharModifiedUTF8, decodeChar) +import qualified Z.Data.Vector.Base as V +import Z.Foreign hiding (fromStdString) +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. @@ -160,44 +160,45 @@ 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 #-} - unalignedSize (CBytes arr) = sizeofPrimArray arr - {-# INLINE peekMBA #-} - peekMBA mba# i = do - b <- getSizeofMutableByteArray (MutableByteArray mba#) - let rest = b-i - l <- c_memchr mba# i 0 rest - let l' = if l == -1 then rest else l - mpa <- newPrimArray (l'+1) - copyMutablePrimArray mpa 0 (MutablePrimArray mba#) i l' - -- write \\NUL terminator - writePrimArray mpa l' 0 - pa <- unsafeFreezePrimArray mpa - return (CBytes pa) +-- | Poke 'CBytes' until a \\NUL terminator(or to the end of the array if there's none). +peekMBACBytes :: MBA# Word8 -> Int -> IO CBytes +{-# INLINE peekMBACBytes #-} +peekMBACBytes mba# i = do + b <- getSizeofMutableByteArray (MutableByteArray mba#) + let rest = b-i + l <- c_memchr mba# i 0 rest + let l' = if l == -1 then rest else l + mpa <- newPrimArray (l'+1) + copyMutablePrimArray mpa 0 (MutablePrimArray mba#) i l' + -- write \\NUL terminator + writePrimArray mpa l' 0 + pa <- unsafeFreezePrimArray mpa + return (CBytes pa) - {-# INLINE pokeMBA #-} - pokeMBA mba# i (CBytes pa) = do +-- | Poke 'CBytes' with \\NUL terminator. +pokeMBACBytes :: MBA# Word8 -> Int -> CBytes -> IO () +{-# INLINE pokeMBACBytes #-} +pokeMBACBytes mba# i (CBytes pa) = do let l = sizeofPrimArray pa copyPrimArray (MutablePrimArray mba# :: MutablePrimArray RealWorld Word8) i pa 0 l - {-# INLINE indexBA #-} - indexBA ba# i = runST (do - let b = sizeofByteArray (ByteArray ba#) - rest = b-i - l = V.c_memchr ba# i 0 rest - l' = if l == -1 then rest else l - mpa <- newPrimArray (l'+1) - copyPrimArray mpa 0 (PrimArray ba#) i l' - writePrimArray mpa l' 0 - pa <- unsafeFreezePrimArray mpa - return (CBytes pa)) +indexBACBytes :: BA# Word8 -> Int -> CBytes +{-# INLINE indexBACBytes #-} +indexBACBytes ba# i = runST (do + let b = sizeofByteArray (ByteArray ba#) + rest = b-i + l = V.c_memchr ba# i 0 rest + l' = if l == -1 then rest else l + mpa <- newPrimArray (l'+1) + copyPrimArray mpa 0 (PrimArray ba#) i l' + writePrimArray mpa l' 0 + pa <- unsafeFreezePrimArray mpa + return (CBytes pa)) -- | This instance provide UTF8 guarantee, illegal codepoints will be written as 'T.replacementChar's. -- -- Escaping rule is same with 'String'. -instance T.ShowT CBytes where +instance T.Print CBytes where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP _ = T.stringUTF8 . show . unpack @@ -482,7 +483,7 @@ -- | Write 'CBytes' \'s byte sequence to buffer. -- --- This function is different from 'T.ShowT' instance in that it directly write byte sequence without +-- This function is different from 'T.Print' instance in that it directly write byte sequence without -- checking if it's UTF8 encoded. toBuilder :: CBytes -> B.Builder () toBuilder = B.bytes . toBytes @@ -603,6 +604,16 @@ writePrimArray mba l' 0 bs <- unsafeFreezePrimArray mba return (CBytes bs, a) + +-- | Run FFI in bracket and marshall @std::string*@ result into 'CBytes', +-- memory pointed by @std::string*@ will be @delete@ ed. +fromStdString :: IO (Ptr StdString) -> IO CBytes +fromStdString f = bracket f hs_delete_std_string + (\ q -> do + siz <- hs_std_string_size q + let !siz' = siz + 1 + (bs,_) <- allocPrimArrayUnsafe siz' (hs_copy_std_string q siz') + return (CBytes bs)) -------------------------------------------------------------------------------- diff --git a/Z/Data/JSON.hs b/Z/Data/JSON.hs --- a/Z/Data/JSON.hs +++ b/Z/Data/JSON.hs @@ -29,24 +29,21 @@ , Value(..) -- * parse into JSON Value , parseValue, parseValue', parseValueChunks, parseValueChunks' + -- * FromValue, ToValue & EncodeJSON + , FromValue(..) + , ToValue(..) + , EncodeJSON(..) + , defaultSettings, Settings(..), snakeCase, trainCase + , gToValue, gFromValue, gEncodeJSON -- * Convert 'Value' to Haskell data , convert, convert', Converter(..), fail', (), prependContext - , PathElement(..), ConvertError + , PathElement(..), ConvertError(..) , typeMismatch, fromNull, withBool, withScientific, withBoundedScientific, withRealFloat , withBoundedIntegral, withText, withArray, withKeyValues, withFlatMap, withFlatMapR , withHashMap, withHashMapR, withEmbeddedJSON , (.:), (.:?), (.:!), convertField, convertFieldMaybe, convertFieldMaybe' - -- * FromValue, ToValue & EncodeJSON - , ToValue(..) - , FromValue(..) - , EncodeJSON(..) - , defaultSettings, Settings(..), snakeCase, trainCase - , gToValue, gFromValue, gEncodeJSON - -- * Helper for manually writing encoders - , kv, kv' - , string - , commaSepList - , commaSepVec + -- * Helper for manually writing instance. + , (.=), object, (.!), object', KVItem ) where import Data.Char @@ -129,42 +126,40 @@ -- > encodeJSON = JSON.gEncodeJSON JSON.defaultSettings{ JSON.fieldFmt = JSON.snakeCase } . from -- -- >>> JSON.toValue (T 0 [1,2,3]) --- Object [(\"foo_t\",Number 0.0),(\"bar_t\",Array [Number 1.0,Number 2.0,Number 3.0])] - +-- Object [("foo_t",Number 0.0),("bar_t",Array [Number 1.0,Number 2.0,Number 3.0])] +-- -- $manually-instance -- -- You can write 'ToValue' and 'FromValue' instances by hand if the 'Generic' based one doesn't suit you. -- Here is an example similar to aeson's. -- --- > import qualified Z.Data.Text as T --- > import qualified Z.Data.Vector as V --- > import qualified Z.Data.Builder as B --- > import qualified Z.Data.JSON as JSON --- > import Z.Data.JSON ((.:), kv, commaSepList, --- > FromValue(..), ToValue(..), EncodeJSON(..)) --- > --- > data Person = Person { name :: T.Text , age :: Int } deriving Show --- > --- > instance FromValue Person where --- > fromValue = JSON.withFlatMapR \"Person\" $ \\ v -> Person --- > \<$\> v .: \"name\" --- > \<*\> v .: \"age\" --- > --- > instance ToValue Person where --- > toValue (Person n a) = JSON.Object $ V.pack [(\"name\", toValue n),(\"age\", toValue a)] --- > --- > instance EncodeJSON Person where --- > encodeJSON (Person n a) = B.curly . commaSepList $ [ --- > \"name\" `kv` string n --- > , \"age\" `kv` B.int a --- > ] +-- @ +-- import qualified Z.Data.Text as T +-- import qualified Z.Data.Vector as V +-- import qualified Z.Data.Builder as B +-- import qualified Z.Data.JSON as JSON +-- import Z.Data.JSON ((.:), (.=), (.!), FromValue(..), ToValue(..), EncodeJSON(..)) -- --- >>> toValue (Person \"Joe\" 12) --- Object [(\"name\",String \"Joe\"),(\"age\",Number 12.0)] --- >>> JSON.convert' @Person . JSON.Object $ V.pack [(\"name\",JSON.String \"Joe\"),(\"age\",JSON.Number 12.0)] --- Right (Person {name = \"Joe\", age = 12}) --- >>> JSON.encodeText (Person \"Joe\" 12) --- "{\"name\":\"Joe\",\"age\":12}" +-- data Person = Person { name :: T.Text , age :: Int } deriving Show +-- +-- instance FromValue Person where +-- fromValue = JSON.withFlatMapR \"Person\" $ \\ v -> Person +-- \<$\> v .: \"name\" +-- \<*\> v .: \"age\" +-- +-- instance ToValue Person where +-- toValue (Person n a) = JSON.object [\"name\" .= n, \"age\" .= a] +-- +-- instance EncodeJSON Person where +-- encodeJSON (Person n a) = JSON.object' $ (\"name\" .! n <> \"age\" .! a) +-- @ +-- +-- >>> toValue (Person "Joe" 12) +-- Object [("name",String "Joe"),("age",Number 12.0)] +-- >>> JSON.convert' @Person . JSON.Object $ V.pack [("name",JSON.String "Joe"),("age",JSON.Number 12.0)] +-- Right (Person {name = "Joe", age = 12}) +-- >>> JSON.encodeText (Person "Joe" 12) +-- "{"name":"Joe","age":12}" -- -- The 'Value' type is different from aeson's one in that we use @Vector (Text, Value)@ to represent JSON objects, thus -- we can choose different strategies on key duplication, the lookup map type, etc. so instead of a single 'withObject', 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 @@ -23,7 +23,7 @@ , JV.parseValue, JV.parseValue', JV.parseValueChunks, JV.parseValueChunks' -- * Convert 'Value' to Haskell data , convert, convert', Converter(..), fail', (), prependContext - , PathElement(..), ConvertError + , PathElement(..), ConvertError(..) , typeMismatch, fromNull, withBool, withScientific, withBoundedScientific, withRealFloat , withBoundedIntegral, withText, withArray, withKeyValues, withFlatMap, withFlatMapR , withHashMap, withHashMapR, withEmbeddedJSON @@ -37,9 +37,11 @@ , Field, GWriteFields(..), GMergeFields(..), GConstrToValue(..) , LookupTable, GFromFields(..), GBuildLookup(..), GConstrFromValue(..) , GAddPunctuation(..), GConstrEncodeJSON(..) - -- * Helper for manually writing encoders + -- * Helper for manually writing instance. + , (.=), object, (.!), object', KVItem , JB.kv, JB.kv' , JB.string + , B.curly, B.square , commaSepList , commaSepVec ) where @@ -70,11 +72,14 @@ import Data.Proxy (Proxy (..)) import Data.Ratio (Ratio, denominator, numerator, (%)) -import Data.Scientific (Scientific, base10Exponent, - toBoundedInteger) +import Data.Scientific (Scientific, base10Exponent, toBoundedInteger) import qualified Data.Scientific as Scientific import qualified Data.Semigroup as Semigroup import Data.Tagged (Tagged (..)) +import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time.Calendar (CalendarDiffDays (..), DayOfWeek (..)) +import Data.Time.LocalTime (CalendarDiffTime (..)) +import Data.Time.Clock.System (SystemTime (..)) import Data.Version (Version, parseVersion) import Data.Word import Foreign.C.Types @@ -91,8 +96,9 @@ import qualified Z.Data.JSON.Value as JV import qualified Z.Data.Parser as P import qualified Z.Data.Parser.Numeric as P +import qualified Z.Data.Text.Base as T import qualified Z.Data.Text as T -import qualified Z.Data.Text.ShowT as T +import qualified Z.Data.Text.Print 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 @@ -172,7 +178,7 @@ {-# INLINE encodeChunks #-} encodeChunks = B.buildChunks . encodeJSON --- | Text version 'encodeBytes'. +-- | Text version 'encode'. encodeText :: EncodeJSON a => a -> T.Text {-# INLINE encodeText #-} encodeText = T.Text . encode @@ -208,7 +214,7 @@ instance Show ConvertError where show = T.toString -instance T.ShowT ConvertError where +instance T.Print ConvertError where toUTF8BuilderP _ (ConvertError [] msg) = T.toUTF8Builder msg toUTF8BuilderP _ (ConvertError paths msg) = do mapM_ renderPath (reverse paths) @@ -497,6 +503,35 @@ {-# INLINE commaSepVec #-} commaSepVec = B.intercalateVec B.comma encodeJSON +-- | A newtype for 'B.Builder', whose semigroup's instance is to connect two builder with 'B.comma'. +newtype KVItem = KVItem (B.Builder ()) + +instance Semigroup KVItem where + {-# INLINE (<>) #-} + KVItem a <> KVItem b = KVItem (a >> B.comma >> b) + +-- | Connect key and value to a 'KVItem' using 'B.colon', key will be escaped. +(.!) :: EncodeJSON v => T.Text -> v -> KVItem +{-# INLINE (.!) #-} +k .! v = KVItem (k `JB.kv'` encodeJSON v) +infixr 8 .! + +-- | Add curly for comma connected 'KVItem's. +object' :: KVItem -> B.Builder () +{-# INLINE object' #-} +object' (KVItem kvb) = B.curly kvb + +-- | Connect key and value to a tuple to be used with 'object'. +(.=) :: ToValue v => T.Text -> v -> (T.Text, Value) +{-# INLINE (.=) #-} +k .= v = (k, toValue v) +infixr 8 .= + +-- | Alias for @Object . pack@. +object :: [(T.Text, Value)] -> Value +{-# INLINE object #-} +object = Object . V.pack + -------------------------------------------------------------------------------- -- | Generic encode/decode Settings @@ -1317,6 +1352,171 @@ instance HasResolution a => EncodeJSON (Fixed a) where {-# INLINE encodeJSON #-} encodeJSON = B.scientific . realToFrac + +-------------------------------------------------------------------------------- + +instance FromValue UTCTime where + {-# INLINE fromValue #-} + fromValue = withText "UTCTime" $ \ t -> + case P.parse' (P.utcTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as UTCTime: " <> T.toText err + Right r -> return r +instance ToValue UTCTime where + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.utcTime t)) +-- @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance EncodeJSON UTCTime where + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.utcTime + +instance FromValue ZonedTime where + {-# INLINE fromValue #-} + fromValue = withText "ZonedTime" $ \ t -> + case P.parse' (P.zonedTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as ZonedTime: " <> T.toText err + Right r -> return r +instance ToValue ZonedTime where + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.zonedTime t)) +-- @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance EncodeJSON ZonedTime where + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.zonedTime + +instance FromValue Day where + {-# INLINE fromValue #-} + fromValue = withText "Day" $ \ t -> + case P.parse' (P.day <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as Day: " <> T.toText err + Right r -> return r +instance ToValue Day where + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.day t)) +-- @YYYY-MM-DD@ +instance EncodeJSON Day where + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.day + + +instance FromValue LocalTime where + {-# INLINE fromValue #-} + fromValue = withText "LocalTime" $ \ t -> + case P.parse' (P.localTime <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse date as LocalTime: " <> T.toText err + Right r -> return r +instance ToValue LocalTime where + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.localTime t)) +-- @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance EncodeJSON LocalTime where + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.localTime + +instance FromValue TimeOfDay where + {-# INLINE fromValue #-} + fromValue = withText "TimeOfDay" $ \ t -> + case P.parse' (P.timeOfDay <* P.endOfInput) (T.getUTF8Bytes t) of + Left err -> fail' $ "could not parse time as TimeOfDay: " <> T.toText err + Right r -> return r +instance ToValue TimeOfDay where + {-# INLINE toValue #-} + toValue t = String (B.unsafeBuildText (B.timeOfDay t)) +-- @YYYY-MM-DDTHH:MM:SS.SSSZ@ +instance EncodeJSON TimeOfDay where + {-# INLINE encodeJSON #-} + encodeJSON = B.quotes . B.timeOfDay + +-- | This instance includes a bounds check to prevent maliciously +-- large inputs to fill up the memory of the target system. You can +-- newtype 'NominalDiffTime' and provide your own instance using +-- 'withScientific' if you want to allow larger inputs. +instance FromValue NominalDiffTime where + {-# INLINE fromValue #-} + fromValue = withBoundedScientific "NominalDiffTime" $ pure . realToFrac +instance ToValue NominalDiffTime where + {-# INLINE toValue #-} + toValue = Number . realToFrac +instance EncodeJSON NominalDiffTime where + {-# INLINE encodeJSON #-} + encodeJSON = B.scientific . realToFrac + + +-- | This instance includes a bounds check to prevent maliciously +-- large inputs to fill up the memory of the target system. You can +-- newtype 'DiffTime' and provide your own instance using +-- 'withScientific' if you want to allow larger inputs. +instance FromValue DiffTime where + {-# INLINE fromValue #-} + fromValue = withBoundedScientific "DiffTime" $ pure . realToFrac +instance ToValue DiffTime where + {-# INLINE toValue #-} + toValue = Number . realToFrac +instance EncodeJSON DiffTime where + {-# INLINE encodeJSON #-} + encodeJSON = B.scientific . realToFrac + +instance FromValue SystemTime where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "SystemTime" $ \ v -> + MkSystemTime <$> v .: "seconds" <*> v .: "nanoseconds" +instance ToValue SystemTime where + {-# INLINE toValue #-} + toValue (MkSystemTime s ns) = object [ "seconds" .= s , "nanoseconds" .= ns ] +instance EncodeJSON SystemTime where + {-# INLINE encodeJSON #-} + encodeJSON (MkSystemTime s ns) = object' $ ("seconds" .! s <> "nanoseconds" .! ns) + +instance FromValue CalendarDiffTime where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "CalendarDiffTime" $ \ v -> + CalendarDiffTime <$> v .: "months" <*> v .: "time" +instance ToValue CalendarDiffTime where + {-# INLINE toValue #-} + toValue (CalendarDiffTime m nt) = object [ "months" .= m , "time" .= nt ] +instance EncodeJSON CalendarDiffTime where + {-# INLINE encodeJSON #-} + encodeJSON (CalendarDiffTime m nt) = object' $ ("months" .! m <> "time" .! nt) + +instance FromValue CalendarDiffDays where + {-# INLINE fromValue #-} + fromValue = withFlatMapR "CalendarDiffDays" $ \ v -> + CalendarDiffDays <$> v .: "months" <*> v .: "days" +instance ToValue CalendarDiffDays where + {-# INLINE toValue #-} + toValue (CalendarDiffDays m d) = object ["months" .= m, "days" .= d] +instance EncodeJSON CalendarDiffDays where + {-# INLINE encodeJSON #-} + encodeJSON (CalendarDiffDays m d) = object' $ ("months" .! m <> "days" .! d) + +instance FromValue DayOfWeek where + {-# INLINE fromValue #-} + fromValue (String "monday" ) = pure Monday + fromValue (String "tuesday" ) = pure Tuesday + fromValue (String "wednesday") = pure Wednesday + fromValue (String "thursday" ) = pure Thursday + fromValue (String "friday" ) = pure Friday + fromValue (String "saturday" ) = pure Saturday + fromValue (String "sunday" ) = pure Sunday + fromValue (String _ ) = fail' "converting DayOfWeek failed, value should be one of weekdays" + fromValue v = typeMismatch "DayOfWeek" "String" v +instance ToValue DayOfWeek where + {-# INLINE toValue #-} + toValue Monday = String "monday" + toValue Tuesday = String "tuesday" + toValue Wednesday = String "wednesday" + toValue Thursday = String "thursday" + toValue Friday = String "friday" + toValue Saturday = String "saturday" + toValue Sunday = String "sunday" +instance EncodeJSON DayOfWeek where + {-# INLINE encodeJSON #-} + encodeJSON Monday = "monday" + encodeJSON Tuesday = "tuesday" + encodeJSON Wednesday = "wednesday" + encodeJSON Thursday = "thursday" + encodeJSON Friday = "friday" + encodeJSON Saturday = "saturday" + encodeJSON Sunday = "sunday" -------------------------------------------------------------------------------- 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 @@ -26,14 +26,17 @@ ) where import Control.Monad +import Z.Data.ASCII import qualified Z.Data.Builder as B import qualified Z.Data.Text as T -import qualified Z.Data.Text.ShowT as T +import qualified Z.Data.Text.Print as T import Z.Data.Vector.Base as V import Z.Data.JSON.Value (Value(..)) -import Data.Scientific (Scientific, base10Exponent, coefficient) +import Data.Scientific (Scientific, base10Exponent, coefficient) --- | Use @:@ as separator to connect a label(no need to escape, only add quotes) with field builders. +-- | Use @:@ as separator to connect a label(no escape, only add quotes) with field builders. +-- +-- Don't use chars which need escaped in label. kv :: T.Text -> B.Builder () -> B.Builder () {-# INLINE kv #-} l `kv` b = B.quotes (B.text l) >> B.colon >> b @@ -96,7 +99,7 @@ | e == 0 = B.integer c | otherwise = do B.integer c - when (c /= 0) (replicateM_ e (B.encodePrim B.ZERO)) + when (c /= 0) (replicateM_ e (B.encodePrim DIGIT_0)) where e = base10Exponent s c = coefficient s 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 @@ -46,8 +46,8 @@ import GHC.Generics import qualified Z.Data.Parser as P import Z.Data.Parser (()) -import qualified Z.Data.Text as T -import Z.Data.Text.ShowT (ShowT(..)) +import qualified Z.Data.Text.Base as T +import Z.Data.Text.Print (Print(..)) import Z.Data.Vector.Base as V import Z.Data.Vector.Extra as V import Z.Foreign @@ -91,8 +91,8 @@ | Number {-# UNPACK #-} !Scientific | Bool !Bool | Null - deriving (Eq, Show, Typeable, Generic) - deriving anyclass ShowT + deriving (Eq, Ord, Show, Typeable, Generic) + deriving anyclass Print 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 @@ -38,13 +38,13 @@ , decodePrim, decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith - , word8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces + , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces , take, takeTill, takeWhile, takeWhile1, bytes, bytesCI , text -- * Numeric parsers -- ** Decimal , uint, int, integer - , uint_, int_ + , uint_, int_, digit -- ** Hex , hex, hex', hex_ -- ** Fractional @@ -57,10 +57,18 @@ , float', double' , scientific' , scientifically' + -- * Time + , day + , localTime + , timeOfDay + , timeZone + , utcTime + , zonedTime -- * Misc - , isSpace, isHexDigit, isDigit, fail' + , fail' ) where import Z.Data.Parser.Base import Z.Data.Parser.Numeric +import Z.Data.Parser.Time import Prelude hiding (take, takeWhile) 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 @@ -27,11 +27,10 @@ , decodePrim, decodePrimLE, decodePrimBE -- * More parsers , scan, scanChunks, peekMaybe, peek, satisfy, satisfyWith - , word8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces + , anyWord8, word8, anyChar8, char8, skipWord8, endOfLine, skip, skipWhile, skipSpaces , take, takeN, takeTill, takeWhile, takeWhile1, bytes, bytesCI , text -- * Misc - , isSpace , fail' ) where @@ -45,6 +44,7 @@ import GHC.Types import Prelude hiding (take, takeWhile) import Z.Data.Array.Unaligned +import Z.Data.ASCII import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Extra as V @@ -290,7 +290,7 @@ let !r = indexPrimWord8ArrayAs ba i in k r (V.PrimVector ba (i+n) (len-n))) where - n = unalignedSize (undefined :: a) + n = getUnalignedSize (unalignedSize @a) decodePrimLE :: forall a. (Unaligned (LE a)) => Parser a {-# INLINE decodePrimLE #-} @@ -308,7 +308,7 @@ let !r = indexPrimWord8ArrayAs ba i in k (getLE r) (V.PrimVector ba (i+n) (len-n))) where - n = unalignedSize (undefined :: (LE a)) + n = getUnalignedSize (unalignedSize @(LE a)) decodePrimBE :: forall a. (Unaligned (BE a)) => Parser a {-# INLINE decodePrimBE #-} @@ -326,7 +326,7 @@ let !r = indexPrimWord8ArrayAs ba i in k (getBE r) (V.PrimVector ba (i+n) (len-n))) where - n = unalignedSize (undefined :: (BE a)) + n = getUnalignedSize (unalignedSize @(BE a)) -- | A stateful scanner. The predicate consumes and transforms a -- state argument, and each transformed state is passed to successive @@ -454,12 +454,25 @@ then k () (V.unsafeTail inp) else kf ["Z.Data.Parser.Base.word8: mismatch byte"] inp) +-- | Return a byte, this is an alias to @decodePrim @Word8@. +-- +anyWord8 :: Parser Word8 +{-# INLINE anyWord8 #-} +anyWord8 = decodePrim + -- | Match a specific 8bit char. -- char8 :: Char -> Parser () {-# INLINE char8 #-} -char8 = word8 . V.c2w +char8 = word8 . c2w +-- | Take a byte and return as a 8bit char. +-- +anyChar8 :: Parser Char +{-# INLINE anyChar8 #-} +anyChar8 = do + w <- anyWord8 + return $! w2c w -- | Match either a single newline byte @\'\\n\'@, or a carriage -- return followed by a newline byte @\"\\r\\n\"@. @@ -539,11 +552,6 @@ skipSpaces :: Parser () {-# INLINE skipSpaces #-} skipSpaces = skipWhile isSpace - --- | @isSpace w = w == 32 || w - 9 <= 4 || w == 0xA0@ -isSpace :: Word8 -> Bool -{-# INLINE isSpace #-} -isSpace w = w == 32 || w - 9 <= 4 || w == 0xA0 take :: Int -> Parser V.Bytes {-# INLINE take #-} 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 @@ -14,7 +14,7 @@ module Z.Data.Parser.Numeric ( -- * Decimal uint, int, integer - , uint_, int_ + , uint_, int_, digit -- * Hex , hex, hex', hex_ -- * Fractional @@ -28,11 +28,10 @@ , scientific' , scientifically' -- * Misc + , w2iHex, w2iDec , hexLoop , decLoop , decLoopIntegerFast - , isHexDigit - , isDigit , floatToScientific , doubleToScientific ) where @@ -43,9 +42,8 @@ import Data.Int import qualified Data.Scientific as Sci import Data.Word +import Z.Data.ASCII import qualified Z.Data.Builder.Numeric as B -import Z.Data.Builder.Numeric (pattern PLUS, pattern MINUS, pattern ZERO, - pattern DOT, pattern LITTLE_E, pattern BIG_E) import Z.Data.Parser.Base (Parser, ()) import qualified Z.Data.Parser.Base as P import qualified Z.Data.Vector.Base as V @@ -55,7 +53,7 @@ #define INT64_SAFE_DIGITS_LEN 18 --- | Parse and decode an unsigned hex number, fail in case of overflow. The hex digits +-- | Parse and decode an unsigned hex number, fail if input length is larger than (bit_size/4). The hex digits -- @\'a\'@ through @\'f\'@ may be upper or lower case. -- -- This parser does not accept a leading @\"0x\"@ string, and consider @@ -98,24 +96,24 @@ hex_ = "Z.Data.Parser.Numeric.hex_" hexLoop 0 <$> P.takeWhile1 isHexDigit -- | decode hex digits sequence within an array. -hexLoop :: (Integral a, Bits a) +hexLoop :: forall a. (Integral a, Bits a) => a -- ^ accumulator, usually start from 0 -> V.Bytes -> a {-# INLINE hexLoop #-} hexLoop = V.foldl' step where - step a w = a `unsafeShiftL` 4 + fromIntegral (w2iHex w) - w2iHex w - | w <= 57 = w - 48 - | w <= 70 = w - 55 - | w <= 102 = w - 87 + step a w = a `unsafeShiftL` 4 + fromIntegral (w2iHex w :: a) --- | A fast digit predicate. -isHexDigit :: Word8 -> Bool -{-# INLINE isHexDigit #-} -isHexDigit w = w - 48 <= 9 || w - 65 <= 5 || w - 97 <= 5 +-- | Convert A ASCII hex digit to 'Int' value. +w2iHex :: Integral a => Word8 -> a +{-# INLINE w2iHex #-} +w2iHex w + | w <= 57 = fromIntegral w - 48 + | w <= 70 = fromIntegral w - 55 + | w <= 102 = fromIntegral w - 87 + -- | Same with 'uint', but sliently cast in case of overflow. uint_ :: forall a. (Integral a, Bounded a) => Parser a {-# INLINE uint_ #-} @@ -149,8 +147,15 @@ -> a {-# INLINE decLoop #-} decLoop = V.foldl' step - where step a w = a * 10 + fromIntegral (w - 48) + where step a w = a * 10 + w2iDec w + +-- | Convert A ASCII decimal digit to 'Int' value. +-- +w2iDec :: Integral a => Word8 -> a +{-# INLINE w2iDec #-} +w2iDec w = fromIntegral w - 48 + -- | decode digits sequence within an array. -- -- A fast version to decode 'Integer' using machine word as much as possible. @@ -160,11 +165,14 @@ | V.length bs <= WORD64_SAFE_DIGITS_LEN = fromIntegral (decLoop @Word64 0 bs) | otherwise = decLoop @Integer 0 bs --- | A fast digit predicate. -isDigit :: Word8 -> Bool -isDigit w = w - 48 <= 9 -{-# INLINE isDigit #-} +-- | Take a single decimal digit and return as 'Int'. +-- +digit :: Parser Int +digit = do + d <- P.satisfy isDigit + return $! w2iDec d + -- | Parse a decimal number with an optional leading @\'+\'@ or @\'-\'@ sign -- character. -- @@ -324,7 +332,7 @@ where {-# INLINE parseE #-} parseE c e = - (do _ <- P.satisfy (\w -> w == LITTLE_E || w == BIG_E) + (do _ <- P.satisfy (\w -> w == LETTER_e || w == LETTER_E) Sci.scientific c . subtract e <$> int) <|> pure (Sci.scientific c (negate e)) -------------------------------------------------------------------------------- @@ -406,7 +414,7 @@ !sign <- P.peek when (sign == MINUS) (P.skipWord8) -- no leading plus is allowed !intPart <- P.takeWhile1 isDigit - when (V.length intPart > 1 && V.head intPart == ZERO) (P.fail' "leading zeros are not allowed") + when (V.length intPart > 1 && V.head intPart == DIGIT_0) (P.fail' "leading zeros are not allowed") mdot <- P.peekMaybe !sci <- case mdot of Just DOT -> do @@ -430,7 +438,7 @@ parseE !c !e = do me <- P.peekMaybe e' <- case me of - Just ec | ec == LITTLE_E || ec == BIG_E -> P.skipWord8 *> int + Just ec | ec == LETTER_e || ec == LETTER_E -> P.skipWord8 *> int _ -> pure 0 pure $! Sci.scientific c (e' - e) diff --git a/Z/Data/Parser/Time.hs b/Z/Data/Parser/Time.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Parser/Time.hs @@ -0,0 +1,142 @@ +{-| +Module: Z.Data.Parser.Time +Description : Parsers for types from time. +Copyright: (c) 2015-2016 Bryan O'Sullivan + (c) 2020 Dong Han +License: BSD3 +Maintainer: Dong +Stability: experimental +Portability: portable + +Parsers for parsing dates and times. +-} + +module Z.Data.Parser.Time + ( day + , localTime + , timeOfDay + , timeZone + , utcTime + , zonedTime + ) where + +import Control.Applicative ((<|>)) +import Z.Data.Parser.Base (Parser) +import qualified Z.Data.Parser.Base as P +import qualified Z.Data.Parser.Numeric as P +import Z.Data.ASCII +import Data.Fixed (Pico, Fixed(..)) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, fromGregorianValid) +import Data.Time.Clock (UTCTime(..)) +import qualified Z.Data.Vector as V +import Data.Time.LocalTime hiding (utc) + +-- | Parse a date of the form @[+,-]YYYY-MM-DD@. +day :: Parser Day +day = "date must be of form [+,-]YYYY-MM-DD" P. do + absOrNeg <- negate <$ P.word8 MINUS <|> id <$ P.word8 PLUS <|> pure id + y <- (P.integer <* P.word8 HYPHEN) + m <- (twoDigits <* P.word8 HYPHEN) + d <- twoDigits + maybe (P.fail' "invalid date") return (fromGregorianValid (absOrNeg y) m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- P.digit + b <- P.digit + return $! a * 10 + b + +-- | Parse a time of the form @HH:MM[:SS[.SSS]]@. +timeOfDay :: Parser TimeOfDay +timeOfDay = do + h <- twoDigits + m <- P.char8 ':' *> twoDigits + s <- (P.char8 ':' *> seconds) <|> pure 0 + if h < 24 && m < 60 && s < 61 + then return (TimeOfDay h m s) + else P.fail' "invalid time" + + +-- | Parse a count of seconds, with the integer part being two digits -- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mw <- P.peekMaybe + case mw of + Just DOT -> do + t <- P.skipWord8 *> P.takeWhile1 isDigit + return $! parsePicos real t + _ -> return $! fromIntegral real + where + parsePicos a0 t = + let V.IPair n t' = V.foldl' step (V.IPair 12 (fromIntegral a0 :: Int64)) t + step ma@(V.IPair m !a) w + | m <= 0 = ma + | otherwise = V.IPair (m-1) (10 * a + P.w2iDec w) + in MkFixed (fromIntegral (t' * 10^n)) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: Parser (Maybe TimeZone) +timeZone = do + P.skipWhile (== SPACE) + w <- P.satisfy $ \ w -> w == LETTER_Z || w == PLUS || w == MINUS + if w == LETTER_Z + then return Nothing + else do + h <- twoDigits + mm <- P.peekMaybe + m <- case mm of + Just COLON -> P.skipWord8 *> twoDigits + Just d | isDigit d -> twoDigits + _ -> return 0 + let off | w == MINUS = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case () of + _ | off == 0 -> + return Nothing + | off < -720 || off > 840 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = minutesToTimeZone off + in return (Just tz) + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM[:SS[.SSS]]@. +-- The space may be replaced with a @T@. The number of seconds is optional +-- and may be followed by a fractional component. +localTime :: Parser LocalTime +localTime = LocalTime <$> day <* daySep <*> timeOfDay + where daySep = P.satisfy (\ w -> w == LETTER_T || w == SPACE) + +-- | Behaves as 'zonedTime', but converts any time zone offset into a -- UTC time. +utcTime :: Parser UTCTime +utcTime = do + lt@(LocalTime d t) <- localTime + mtz <- timeZone + case mtz of + Nothing -> let !tt = timeOfDayToTime t + in return (UTCTime d tt) + Just tz -> return $! localTimeToUTC tz lt + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @ +-- YYYY-MM-DD HH:MM Z +-- YYYY-MM-DD HH:MM:SS Z +-- YYYY-MM-DD HH:MM:SS.SSS Z +-- @ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: Parser ZonedTime +zonedTime = ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: TimeZone +utc = TimeZone 0 False "" 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,5 +1,6 @@ {-| Module : Z.Data.PrimIORef +Description : Primitive IO Reference Copyright : (c) Dong Han 2017~2019 License : BSD-style 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,6 @@ {-| Module : Z.Data.PrimRef.PrimSTRef +Description : Primitive ST Reference Copyright : (c) Dong Han 2017~2019 License : BSD-style diff --git a/Z/Data/Text.hs b/Z/Data/Text.hs --- a/Z/Data/Text.hs +++ b/Z/Data/Text.hs @@ -16,7 +16,7 @@ module Z.Data.Text ( -- * Text type - Text(..) + Text, getUTF8Bytes , validate, validateASCII , validateMaybe, validateASCIIMaybe , TextException(..) @@ -30,6 +30,8 @@ -- * Conversion between codepoint vector , fromVector , toVector + -- * Print class + , Print(..), toText, toString, toUTF8Builder, toUTF8Bytes -- * Basic interface , null , length @@ -145,6 +147,7 @@ import Z.Data.Text.Base import Z.Data.Text.Search import Z.Data.Text.Extra +import Z.Data.Text.Print import Prelude () 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 @@ -133,6 +133,7 @@ import GHC.Stack import GHC.CString (unpackCString#, unpackCStringUtf8#) import Z.Data.Array +import Z.Data.ASCII (c2w) import Z.Data.Text.UTF8Codec import Z.Data.Text.UTF8Rewind import Z.Data.Vector.Base (Bytes, PrimVector(..), c_strlen) @@ -305,8 +306,8 @@ -- | /O(n)/ Validate a sequence of bytes is all ascii char byte(<128). -- --- Throw 'InvalidASCIIException' in case of invalid byte, It's not faster --- than 'validate', use it only if you want to validate if a ASCII char sequence. +-- Throw 'InvalidASCIIException' in case of invalid byte, It's not always faster +-- than 'validate', use it only if you want to validate ASCII char sequences. -- validateASCII :: HasCallStack => Bytes -> Text {-# INLINE validateASCII #-} @@ -651,7 +652,7 @@ count :: Char -> Text -> Int {-# INLINE count #-} count c (Text v) - | encodeCharLength c == 1 = let w = V.c2w c in V.count w v + | encodeCharLength c == 1 = let w = c2w c in V.count w v | otherwise = let (Text pat) = singleton c in List.length $ V.indices pat v False diff --git a/Z/Data/Text/Print.hs b/Z/Data/Text/Print.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Text/Print.hs @@ -0,0 +1,462 @@ +{-| +Module : Z.Data.Text.Print +Description : UTF8 compatible builders. +Copyright : (c) Dong Han, 2017-2019 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +This module re-exports some UTF8 compatible textual builders from 'Z.Data.Builder'. + +We also provide a faster alternative to 'Show' class, i.e. 'Print', which can be deriving using 'Generic'. +For example to use 'Print' class: + +@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies #-} + +import qualified Z.Data.Text.Print as T + +data Foo = Bar Bytes | Qux Text Int deriving Generic + deriving anyclass T.Print + +@ + +-} + +module Z.Data.Text.Print + ( -- * Print class + Print(..), toText, toString, toUTF8Builder, toUTF8Bytes + -- * Basic UTF8 builders + , escapeTextJSON + , B.stringUTF8, B.charUTF8, B.string7, B.char7, B.text + -- * Numeric builders + -- ** Integral type formatting + , B.IFormat(..) + , B.defaultIFormat + , B.Padding(..) + , B.int + , B.intWith + , B.integer + -- ** Fixded size hexidecimal formatting + , B.hex, B.hexUpper + -- ** IEEE float formating + , B.FFormat(..) + , B.double + , B.doubleWith + , B.float + , B.floatWith + , B.scientific + , B.scientificWith + -- * Helpers + , B.paren, B.curly, B.square, B.angle, B.quotes, B.squotes + , B.colon, B.comma, B.intercalateVec, B.intercalateList + , parenWhen + ) where + +import Control.Monad +import qualified Data.Scientific as Sci +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 qualified Data.Semigroup as Semigroup +import Data.Typeable +import Foreign.C.Types +import GHC.Exts +import GHC.ForeignPtr +import GHC.Generics +import GHC.Natural +import GHC.Stack +import GHC.Word +import Data.Version +import System.Exit +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 + +#define DOUBLE_QUOTE 34 + +-------------------------------------------------------------------------------- +-- 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 Print +-- +-- > toText (FooInt 3) +-- > "FooInt 3" +-- +-- newtype FooInt = FooInt Int deriving (Generic) +-- deriving newtype Print +-- +-- > toText (FooInt 3) +-- > "3" +-- @ +-- +class Print a where + -- | Convert data to 'B.Builder' with precendence. + -- + -- You should return a 'B.Builder' writing in UTF8 encoding only, i.e. + -- + -- @Z.Data.Text.validateMaybe (Z.Data.Builder.buildBytes (toUTF8BuilderP p a)) /= Nothing@ + toUTF8BuilderP :: Int -> a -> B.Builder () + + default toUTF8BuilderP :: (Generic a, GToText (Rep a)) => Int -> a -> B.Builder () + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP p = gToUTF8BuilderP p . from + +-- | Convert data to 'B.Builder'. +toUTF8Builder :: Print a => a -> B.Builder () +{-# INLINE toUTF8Builder #-} +toUTF8Builder = toUTF8BuilderP 0 + +-- | Convert data to 'V.Bytes' in UTF8 encoding. +toUTF8Bytes :: Print a => a -> V.Bytes +{-# INLINE toUTF8Bytes #-} +toUTF8Bytes = B.build . toUTF8BuilderP 0 + +-- | Convert data to 'Text'. +toText :: Print a => a -> Text +{-# INLINE toText #-} +toText = Text . toUTF8Bytes + +-- | Convert data to 'String', faster 'show' replacement. +toString :: Print a => a -> String +{-# INLINE toString #-} +toString = T.unpack . toText + +class GToText f where + gToUTF8BuilderP :: Int -> f a -> B.Builder () + +class GFieldToText f where + gFieldToUTF8BuilderP :: B.Builder () -> Int -> f a -> B.Builder () + +instance (GFieldToText a, GFieldToText b) => GFieldToText (a :*: b) where + {-# INLINE gFieldToUTF8BuilderP #-} + gFieldToUTF8BuilderP sep p (a :*: b) = + gFieldToUTF8BuilderP sep p a >> sep >> gFieldToUTF8BuilderP sep p b + +instance (GToText f) => GFieldToText (S1 (MetaSel Nothing u ss ds) f) where + {-# INLINE gFieldToUTF8BuilderP #-} + gFieldToUTF8BuilderP _ p (M1 x) = gToUTF8BuilderP p x + +instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where + {-# INLINE gFieldToUTF8BuilderP #-} + gFieldToUTF8BuilderP _ _ m1@(M1 x) = + B.stringModifiedUTF8 (selName m1) >> " = " >> gToUTF8BuilderP 0 x + +instance GToText V1 where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP _ = error "Z.Data.Text.Print: empty data type" + +instance (GToText f, GToText g) => GToText (f :+: g) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP p (L1 x) = gToUTF8BuilderP p x + gToUTF8BuilderP p (R1 x) = gToUTF8BuilderP p x + +-- | Constructor without payload, convert to String +instance (Constructor c) => GToText (C1 c U1) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP _ m1 = B.stringModifiedUTF8 $ conName m1 + +-- | Constructor with payloads +instance (GFieldToText (S1 sc f), Constructor c) => GToText (C1 c (S1 sc f)) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP p m1@(M1 x) = + parenWhen (p > 10) $ do + B.stringModifiedUTF8 $ conName m1 + B.char8 ' ' + if conIsRecord m1 + then B.curly $ gFieldToUTF8BuilderP (B.char7 ',' >> B.char7 ' ') p x + else gFieldToUTF8BuilderP (B.char7 ' ') 11 x + +instance (GFieldToText (a :*: b), Constructor c) => GToText (C1 c (a :*: b)) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP p m1@(M1 x) = + case conFixity m1 of + Prefix -> parenWhen (p > 10) $ do + B.stringModifiedUTF8 $ conName m1 + B.char8 ' ' + if conIsRecord m1 + then B.curly $ gFieldToUTF8BuilderP (B.char7 ',' >> B.char7 ' ') p x + else gFieldToUTF8BuilderP (B.char7 ' ') 11 x + Infix _ p' -> parenWhen (p > p') $ do + gFieldToUTF8BuilderP + (B.char8 ' ' >> B.stringModifiedUTF8 (conName m1) >> B.char8 ' ') (p'+1) x + +instance Print a => GToText (K1 i a) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP p (K1 x) = toUTF8BuilderP p x + +-- | Add "(..)" around builders when condition is met, otherwise add nothing. +-- +-- This is useful when defining 'Print' instances. +parenWhen :: Bool -> B.Builder () -> B.Builder () +{-# INLINE parenWhen #-} +parenWhen True b = B.paren b +parenWhen _ b = b + +-------------------------------------------------------------------------------- +-- Data types +instance GToText f => GToText (D1 c f) where + {-# INLINE gToUTF8BuilderP #-} + gToUTF8BuilderP p (M1 x) = gToUTF8BuilderP p x + +instance Print Bool where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ True = "True" + toUTF8BuilderP _ _ = "False" + + +instance Print Char where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.string8 . show + +instance Print Double where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.double;} +instance Print Float where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.float;} + +instance Print Int where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Int8 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Int16 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Int32 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Int64 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Word where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Word8 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Word16 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Word32 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} +instance Print Word64 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} + +instance Print Integer where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.integer;} +instance Print Natural where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.integer . fromIntegral} +instance Print Ordering where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ GT = "GT" + toUTF8BuilderP _ EQ = "EQ" + toUTF8BuilderP _ _ = "LT" + +instance Print () where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ () = "()" + +instance Print Version where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.stringUTF8 . show + +-- | The escaping rules is same with 'Show' instance: we reuse JSON escaping rules here, so it will be faster. +instance Print Text where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = 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.writeN siz (\ 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 (escape_json_string ba# s l (unsafeCoerce# mba#) i)) + +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 Print Sci.Scientific where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.scientific + +instance Print a => Print [a] where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateList B.comma (toUTF8BuilderP 0) + +instance Print a => Print (A.Array a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance Print a => Print (A.SmallArray a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance (A.PrimUnlifted a, Print a) => Print (A.UnliftedArray a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance (Prim a, Print a) => Print (A.PrimArray a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance Print a => Print (V.Vector a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance (Prim a, Print a) => Print (V.PrimVector a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) + +instance (Print a, Print b) => Print (a, b) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + +instance (Print a, Print b, Print c) => Print (a, b, c) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b, c) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + >> B.comma >> toUTF8BuilderP 0 c + +instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b, c, d) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + >> B.comma >> toUTF8BuilderP 0 c + >> B.comma >> toUTF8BuilderP 0 d + +instance (Print a, Print b, Print c, Print d, Print e) => Print (a, b, c, d, e) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b, c, d, e) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + >> B.comma >> toUTF8BuilderP 0 c + >> B.comma >> toUTF8BuilderP 0 d + >> B.comma >> toUTF8BuilderP 0 e + +instance (Print a, Print b, Print c, Print d, Print e, Print f) => Print (a, b, c, d, e, f) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b, c, d, e, f) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + >> B.comma >> toUTF8BuilderP 0 c + >> B.comma >> toUTF8BuilderP 0 d + >> B.comma >> toUTF8BuilderP 0 e + >> B.comma >> toUTF8BuilderP 0 f + +instance (Print a, Print b, Print c, Print d, Print e, Print f, Print g) => Print (a, b, c, d, e, f, g) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (a, b, c, d, e, f, g) = B.paren $ toUTF8BuilderP 0 a + >> B.comma >> toUTF8BuilderP 0 b + >> B.comma >> toUTF8BuilderP 0 c + >> B.comma >> toUTF8BuilderP 0 d + >> B.comma >> toUTF8BuilderP 0 e + >> B.comma >> toUTF8BuilderP 0 f + >> B.comma >> toUTF8BuilderP 0 g + +instance Print a => Print (Maybe a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP p (Just x) = parenWhen (p > 10) $ "Just " >> toUTF8BuilderP 11 x + toUTF8BuilderP _ _ = "Nothing" + +instance (Print a, Print b) => Print (Either a b) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP p (Left x) = parenWhen (p > 10) $ "Left " >> toUTF8BuilderP 11 x + toUTF8BuilderP p (Right x) = parenWhen (p > 10) $ "Right " >> toUTF8BuilderP 11 x + +instance (Print a, Integral a) => Print (Ratio a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP p r = parenWhen (p > 10) $ do + toUTF8BuilderP 8 (numerator r) + " % " + toUTF8BuilderP 8 (denominator r) + +instance HasResolution a => Print (Fixed a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.string8 . show + +instance Print CallStack where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ = B.string8 . show + +deriving newtype instance Print CChar +deriving newtype instance Print CSChar +deriving newtype instance Print CUChar +deriving newtype instance Print CShort +deriving newtype instance Print CUShort +deriving newtype instance Print CInt +deriving newtype instance Print CUInt +deriving newtype instance Print CLong +deriving newtype instance Print CULong +deriving newtype instance Print CPtrdiff +deriving newtype instance Print CSize +deriving newtype instance Print CWchar +deriving newtype instance Print CSigAtomic +deriving newtype instance Print CLLong +deriving newtype instance Print CULLong +deriving newtype instance Print CBool +deriving newtype instance Print CIntPtr +deriving newtype instance Print CUIntPtr +deriving newtype instance Print CIntMax +deriving newtype instance Print CUIntMax +deriving newtype instance Print CClock +deriving newtype instance Print CTime +deriving newtype instance Print CUSeconds +deriving newtype instance Print CSUSeconds +deriving newtype instance Print CFloat +deriving newtype instance Print CDouble + +instance Print (Ptr a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (Ptr a) = + "0x" >> B.hex (W# (int2Word#(addr2Int# a))) +instance Print (ForeignPtr a) where + {-# INLINE toUTF8BuilderP #-} + toUTF8BuilderP _ (ForeignPtr a _) = + "0x" >> B.hex (W# (int2Word#(addr2Int# a))) + +deriving anyclass instance Print ExitCode + +deriving anyclass instance Print a => Print (Semigroup.Min a) +deriving anyclass instance Print a => Print (Semigroup.Max a) +deriving anyclass instance Print a => Print (Semigroup.First a) +deriving anyclass instance Print a => Print (Semigroup.Last a) +deriving anyclass instance Print a => Print (Semigroup.WrappedMonoid a) +deriving anyclass instance Print a => Print (Semigroup.Dual a) +deriving anyclass instance Print a => Print (Monoid.First a) +deriving anyclass instance Print a => Print (Monoid.Last a) +deriving anyclass instance Print a => Print (NonEmpty a) +deriving anyclass instance Print a => Print (Identity a) +deriving anyclass instance Print a => Print (Const a b) +deriving anyclass instance Print (Proxy a) +deriving anyclass instance Print b => Print (Tagged a b) +deriving anyclass instance Print (f (g a)) => Print (Compose f g a) +deriving anyclass instance (Print (f a), Print (g a)) => Print (Product f g a) +deriving anyclass instance (Print (f a), Print (g a), Print a) => Print (Sum f g a) diff --git a/Z/Data/Text/Regex.hs b/Z/Data/Text/Regex.hs --- a/Z/Data/Text/Regex.hs +++ b/Z/Data/Text/Regex.hs @@ -38,7 +38,7 @@ import Foreign.Marshal.Utils (fromBool) import System.IO.Unsafe import qualified Z.Data.Text.Base as T -import qualified Z.Data.Text.ShowT as T +import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Array as A @@ -48,7 +48,7 @@ , regexCaptureNum :: {-# UNPACK #-} !Int -- ^ capturing group number(including @\\0@) , regexPattern :: T.Text -- ^ Get back regex's pattern. } deriving (Show, Generic) - deriving anyclass T.ShowT + deriving anyclass T.Print -- | RE2 Regex options. -- @@ -94,7 +94,7 @@ , word_boundary :: Bool , one_line :: Bool } deriving (Eq, Ord, Show, Generic) - deriving anyclass T.ShowT + deriving anyclass T.Print -- | Default regex options, see 'RegexOpts'. -- diff --git a/Z/Data/Text/ShowT.hs b/Z/Data/Text/ShowT.hs deleted file mode 100644 --- a/Z/Data/Text/ShowT.hs +++ /dev/null @@ -1,462 +0,0 @@ -{-| -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 - -This module re-exports some UTF8 compatible textual builders from 'Z.Data.Builder'. - -We also provide a faster alternative to 'Show' class, i.e. 'ShowT', which can be deriving using 'Generic'. -For example to use 'ShowT' class: - -@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DerivingStrategies #-} - -import qualified Z.Data.Text.ShowT as T - -data Foo = Bar Bytes | Qux Text Int deriving Generic - deriving anyclass T.ShowT - -@ - --} - -module Z.Data.Text.ShowT - ( -- * ShowT class - ShowT(..), toText, toString, toUTF8Builder, toUTF8Bytes - -- * Basic UTF8 builders - , escapeTextJSON - , B.stringUTF8, B.charUTF8, B.string7, B.char7, B.text - -- * Numeric builders - -- ** Integral type formatting - , B.IFormat(..) - , B.defaultIFormat - , B.Padding(..) - , B.int - , B.intWith - , B.integer - -- ** Fixded size hexidecimal formatting - , B.hex, B.hexUpper - -- ** IEEE float formating - , B.FFormat(..) - , B.double - , B.doubleWith - , B.float - , B.floatWith - , B.scientific - , B.scientificWith - -- * Helpers - , B.paren, B.curly, B.square, B.angle, B.quotes, B.squotes - , B.colon, B.comma, B.intercalateVec, B.intercalateList - , parenWhen - ) where - -import Control.Monad -import qualified Data.Scientific as Sci -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 qualified Data.Semigroup as Semigroup -import Data.Typeable -import Foreign.C.Types -import GHC.Exts -import GHC.ForeignPtr -import GHC.Generics -import GHC.Natural -import GHC.Stack -import GHC.Word -import Data.Version -import System.Exit -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 - -#define DOUBLE_QUOTE 34 - --------------------------------------------------------------------------------- --- 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 --- --- > toText (FooInt 3) --- > "FooInt 3" --- --- newtype FooInt = FooInt Int deriving (Generic) --- deriving newtype ShowT --- --- > toText (FooInt 3) --- > "3" --- @ --- -class ShowT a where - -- | Convert data to 'B.Builder' with precendence. - -- - -- You should return a 'B.Builder' writing in UTF8 encoding only, i.e. - -- - -- @Z.Data.Text.validateMaybe (Z.Data.Builder.buildBytes (toUTF8BuilderP p a)) /= Nothing@ - toUTF8BuilderP :: Int -> a -> B.Builder () - - default toUTF8BuilderP :: (Generic a, GToText (Rep a)) => Int -> a -> B.Builder () - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP p = gToUTF8BuilderP p . from - --- | Convert data to 'B.Builder'. -toUTF8Builder :: ShowT a => a -> B.Builder () -{-# INLINE toUTF8Builder #-} -toUTF8Builder = toUTF8BuilderP 0 - --- | Convert data to 'V.Bytes' in UTF8 encoding. -toUTF8Bytes :: ShowT a => a -> V.Bytes -{-# INLINE toUTF8Bytes #-} -toUTF8Bytes = B.build . toUTF8BuilderP 0 - --- | Convert data to 'Text'. -toText :: ShowT a => a -> Text -{-# INLINE toText #-} -toText = Text . toUTF8Bytes - --- | Convert data to 'String', faster 'show' replacement. -toString :: ShowT a => a -> String -{-# INLINE toString #-} -toString = T.unpack . toText - -class GToText f where - gToUTF8BuilderP :: Int -> f a -> B.Builder () - -class GFieldToText f where - gFieldToUTF8BuilderP :: B.Builder () -> Int -> f a -> B.Builder () - -instance (GFieldToText a, GFieldToText b) => GFieldToText (a :*: b) where - {-# INLINE gFieldToUTF8BuilderP #-} - gFieldToUTF8BuilderP sep p (a :*: b) = - gFieldToUTF8BuilderP sep p a >> sep >> gFieldToUTF8BuilderP sep p b - -instance (GToText f) => GFieldToText (S1 (MetaSel Nothing u ss ds) f) where - {-# INLINE gFieldToUTF8BuilderP #-} - gFieldToUTF8BuilderP _ p (M1 x) = gToUTF8BuilderP p x - -instance (GToText f, Selector (MetaSel (Just l) u ss ds)) => GFieldToText (S1 (MetaSel (Just l) u ss ds) f) where - {-# INLINE gFieldToUTF8BuilderP #-} - gFieldToUTF8BuilderP _ _ m1@(M1 x) = - B.stringModifiedUTF8 (selName m1) >> " = " >> gToUTF8BuilderP 0 x - -instance GToText V1 where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP _ = error "Z.Data.Text.ShowT: empty data type" - -instance (GToText f, GToText g) => GToText (f :+: g) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP p (L1 x) = gToUTF8BuilderP p x - gToUTF8BuilderP p (R1 x) = gToUTF8BuilderP p x - --- | Constructor without payload, convert to String -instance (Constructor c) => GToText (C1 c U1) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP _ m1 = B.stringModifiedUTF8 $ conName m1 - --- | Constructor with payloads -instance (GFieldToText (S1 sc f), Constructor c) => GToText (C1 c (S1 sc f)) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP p m1@(M1 x) = - parenWhen (p > 10) $ do - B.stringModifiedUTF8 $ conName m1 - B.char8 ' ' - if conIsRecord m1 - then B.curly $ gFieldToUTF8BuilderP (B.char7 ',' >> B.char7 ' ') p x - else gFieldToUTF8BuilderP (B.char7 ' ') 11 x - -instance (GFieldToText (a :*: b), Constructor c) => GToText (C1 c (a :*: b)) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP p m1@(M1 x) = - case conFixity m1 of - Prefix -> parenWhen (p > 10) $ do - B.stringModifiedUTF8 $ conName m1 - B.char8 ' ' - if conIsRecord m1 - then B.curly $ gFieldToUTF8BuilderP (B.char7 ',' >> B.char7 ' ') p x - else gFieldToUTF8BuilderP (B.char7 ' ') 11 x - Infix _ p' -> parenWhen (p > p') $ do - gFieldToUTF8BuilderP - (B.char8 ' ' >> B.stringModifiedUTF8 (conName m1) >> B.char8 ' ') (p'+1) x - -instance ShowT a => GToText (K1 i a) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP p (K1 x) = toUTF8BuilderP p x - --- | Add "(..)" around builders when condition is met, otherwise add nothing. --- --- This is useful when defining 'ShowT' instances. -parenWhen :: Bool -> B.Builder () -> B.Builder () -{-# INLINE parenWhen #-} -parenWhen True b = B.paren b -parenWhen _ b = b - --------------------------------------------------------------------------------- --- Data types -instance GToText f => GToText (D1 c f) where - {-# INLINE gToUTF8BuilderP #-} - gToUTF8BuilderP p (M1 x) = gToUTF8BuilderP p x - -instance ShowT Bool where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ True = "True" - toUTF8BuilderP _ _ = "False" - - -instance ShowT Char where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.string8 . show - -instance ShowT Double where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.double;} -instance ShowT Float where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.float;} - -instance ShowT Int where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Int8 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Int16 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Int32 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Int64 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Word where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Word8 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Word16 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Word32 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} -instance ShowT Word64 where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.int;} - -instance ShowT Integer where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.integer;} -instance ShowT Natural where {{-# INLINE toUTF8BuilderP #-}; toUTF8BuilderP _ = B.integer . fromIntegral} -instance ShowT Ordering where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ GT = "GT" - toUTF8BuilderP _ EQ = "EQ" - toUTF8BuilderP _ _ = "LT" - -instance ShowT () where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ () = "()" - -instance ShowT Version where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.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 toUTF8BuilderP #-} - toUTF8BuilderP _ = 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.writeN siz (\ 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 (escape_json_string ba# s l (unsafeCoerce# mba#) i)) - -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 toUTF8BuilderP #-} - toUTF8BuilderP _ = B.scientific - -instance ShowT a => ShowT [a] where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateList B.comma (toUTF8BuilderP 0) - -instance ShowT a => ShowT (A.Array a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance ShowT a => ShowT (A.SmallArray a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance (A.PrimUnlifted a, ShowT a) => ShowT (A.UnliftedArray a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance (Prim a, ShowT a) => ShowT (A.PrimArray a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance ShowT a => ShowT (V.Vector a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance (Prim a, ShowT a) => ShowT (V.PrimVector a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.square . B.intercalateVec B.comma (toUTF8BuilderP 0) - -instance (ShowT a, ShowT b) => ShowT (a, b) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - -instance (ShowT a, ShowT b, ShowT c) => ShowT (a, b, c) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b, c) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - >> B.comma >> toUTF8BuilderP 0 c - -instance (ShowT a, ShowT b, ShowT c, ShowT d) => ShowT (a, b, c, d) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b, c, d) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - >> B.comma >> toUTF8BuilderP 0 c - >> B.comma >> toUTF8BuilderP 0 d - -instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e) => ShowT (a, b, c, d, e) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b, c, d, e) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - >> B.comma >> toUTF8BuilderP 0 c - >> B.comma >> toUTF8BuilderP 0 d - >> B.comma >> toUTF8BuilderP 0 e - -instance (ShowT a, ShowT b, ShowT c, ShowT d, ShowT e, ShowT f) => ShowT (a, b, c, d, e, f) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b, c, d, e, f) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - >> B.comma >> toUTF8BuilderP 0 c - >> B.comma >> toUTF8BuilderP 0 d - >> B.comma >> toUTF8BuilderP 0 e - >> B.comma >> toUTF8BuilderP 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 toUTF8BuilderP #-} - toUTF8BuilderP _ (a, b, c, d, e, f, g) = B.paren $ toUTF8BuilderP 0 a - >> B.comma >> toUTF8BuilderP 0 b - >> B.comma >> toUTF8BuilderP 0 c - >> B.comma >> toUTF8BuilderP 0 d - >> B.comma >> toUTF8BuilderP 0 e - >> B.comma >> toUTF8BuilderP 0 f - >> B.comma >> toUTF8BuilderP 0 g - -instance ShowT a => ShowT (Maybe a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP p (Just x) = parenWhen (p > 10) $ "Just " >> toUTF8BuilderP 11 x - toUTF8BuilderP _ _ = "Nothing" - -instance (ShowT a, ShowT b) => ShowT (Either a b) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP p (Left x) = parenWhen (p > 10) $ "Left " >> toUTF8BuilderP 11 x - toUTF8BuilderP p (Right x) = parenWhen (p > 10) $ "Right " >> toUTF8BuilderP 11 x - -instance (ShowT a, Integral a) => ShowT (Ratio a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP p r = parenWhen (p > 10) $ do - toUTF8BuilderP 8 (numerator r) - " % " - toUTF8BuilderP 8 (denominator r) - -instance HasResolution a => ShowT (Fixed a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = B.string8 . show - -instance ShowT CallStack where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ = 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 - -instance ShowT (Ptr a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (Ptr a) = - "0x" >> B.hex (W# (int2Word#(addr2Int# a))) -instance ShowT (ForeignPtr a) where - {-# INLINE toUTF8BuilderP #-} - toUTF8BuilderP _ (ForeignPtr a _) = - "0x" >> B.hex (W# (int2Word#(addr2Int# a))) - -deriving anyclass instance ShowT ExitCode - -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/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -66,7 +66,7 @@ , Vector , PrimVector -- ** Word8 vector - , Bytes, packASCII, w2c, c2w + , Bytes, packASCII -- * Basic creating , empty, singleton, copy -- * Conversion between list 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 @@ -28,7 +28,7 @@ , Vector(..) , PrimVector(..) -- ** Word8 vector - , Bytes, packASCII, w2c, c2w + , Bytes, packASCII -- * Creating utilities , create, create', creating, creating', createN, createN2 , empty, singleton, copy @@ -222,8 +222,8 @@ where !endA = sA + lA !endB = sB + lB - go !i !j | i >= endA = endA `compare` endB - | j >= endB = endA `compare` endB + go !i !j | i >= endA = lA `compare` lB + | j >= endB = lA `compare` lB | otherwise = let o = indexSmallArray baA i `compare` indexSmallArray baB j in case o of EQ -> go (i+1) (j+1) x -> x @@ -398,13 +398,12 @@ 0 == I# (compareByteArrays# baA# (sA# *# siz#) baB# (sB# *# siz#) n#) where !siz@(I# siz#) = sizeOf (undefined :: a) - !(I# n#) = min (lA*siz) (lB*siz) + !(I# n#) = lA*siz instance (Prim a, Ord a) => Ord (PrimVector a) where {-# INLINE compare #-} compare = comparePrimVector - comparePrimVector :: (Prim a, Ord a) => PrimVector a -> PrimVector a -> Ordering {-# INLINE [1] comparePrimVector #-} {-# RULES @@ -416,8 +415,8 @@ where !endA = sA + lA !endB = sB + lB - go !i !j | i >= endA = endA `compare` endB - | j >= endB = endA `compare` endB + go !i !j | i >= endA = lA `compare` lB + | j >= endB = lA `compare` lB | otherwise = let o = indexPrimArray baA i `compare` indexPrimArray baB j in case o of EQ -> go (i+1) (j+1) x -> x @@ -522,18 +521,6 @@ arr <- unsafeFreezePrimArray marr return (PrimVector arr 0 len) --- | Conversion between 'Word8' and 'Char'. Should compile to a no-op. --- -w2c :: Word8 -> Char -{-# INLINE w2c #-} -w2c (W8# w#) = C# (chr# (word2Int# w#)) - --- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and --- silently truncates to 8 bits Chars > @\\255@. It is provided as --- convenience for PrimVector construction. -c2w :: Char -> Word8 -{-# INLINE c2w #-} -c2w (C# c#) = W8# (int2Word# (ord# c#)) -------------------------------------------------------------------------------- -- Basic creating diff --git a/Z/Data/Vector/Base64.hs b/Z/Data/Vector/Base64.hs --- a/Z/Data/Vector/Base64.hs +++ b/Z/Data/Vector/Base64.hs @@ -36,7 +36,7 @@ import qualified Z.Data.Vector.Base as V import qualified Z.Data.Builder.Base as B import qualified Z.Data.Text.Base as T -import qualified Z.Data.Text.ShowT as T +import qualified Z.Data.Text.Print as T import qualified Z.Data.JSON as JSON import Z.Foreign @@ -48,7 +48,7 @@ instance Show Base64Bytes where show (Base64Bytes bs) = T.unpack $ base64EncodeText bs -instance T.ShowT Base64Bytes where +instance T.Print Base64Bytes where {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ (Base64Bytes bs) = B.quotes (base64EncodeBuilder bs) 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 @@ -40,9 +40,9 @@ 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.ShowT as T +import qualified Z.Data.Text.Print as T import Data.Function (on) -import Data.Bits (shiftR) +import Data.Bits (unsafeShiftR) import Data.Data import Prelude hiding (lookup, null) import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -52,7 +52,7 @@ newtype FlatIntMap v = FlatIntMap { sortedKeyValues :: V.Vector (V.IPair v) } deriving (Show, Eq, Ord, Typeable) -instance T.ShowT v => T.ShowT (FlatIntMap v) where +instance T.Print v => T.Print (FlatIntMap v) where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP p (FlatIntMap vec) = T.parenWhen (p > 10) $ do "FlatIntMap{" @@ -184,7 +184,7 @@ | otherwise -> Nothing | s > e = Nothing | otherwise = - let mid = (s+e) `shiftR` 1 + let mid = (s+e) `unsafeShiftR` 1 (V.IPair k v) = arr `A.indexSmallArray` mid in case k' `compare` k of LT -> go s (mid-1) GT -> go (mid+1) e @@ -350,7 +350,7 @@ _ -> Right s | s > e = Left s | otherwise = - let !mid = (s+e) `shiftR` 1 + let !mid = (s+e) `unsafeShiftR` 1 (V.IPair k _) = arr `A.indexSmallArray` mid in case k' `compare` k of LT -> go s (mid-1) GT -> go (mid+1) e 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 @@ -35,8 +35,8 @@ 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.ShowT as T -import Data.Bits (shiftR) +import qualified Z.Data.Text.Print as T +import Data.Bits (unsafeShiftR) import Data.Data import Prelude hiding (elem, null) import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -46,7 +46,7 @@ newtype FlatIntSet = FlatIntSet { sortedValues :: V.PrimVector Int } deriving (Show, Eq, Ord, Typeable) -instance T.ShowT FlatIntSet where +instance T.Print FlatIntSet where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP p (FlatIntSet vec) = T.parenWhen (p > 10) $ do "FlatIntSet{" @@ -212,7 +212,7 @@ _ -> Right s | s > e = Left s | otherwise = - let !mid = (s+e) `shiftR` 1 + let !mid = (s+e) `unsafeShiftR` 1 v = arr `A.indexPrimArray` mid in case v' `compare` v of LT -> go s (mid-1) GT -> go (mid+1) e 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 @@ -40,9 +40,9 @@ 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.ShowT as T +import qualified Z.Data.Text.Print as T import Data.Function (on) -import Data.Bits (shiftR) +import Data.Bits (unsafeShiftR) import Data.Data import Prelude hiding (lookup, null) import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -52,7 +52,7 @@ newtype FlatMap k v = FlatMap { sortedKeyValues :: V.Vector (k, v) } deriving (Show, Eq, Ord, Typeable) -instance (T.ShowT k, T.ShowT v) => T.ShowT (FlatMap k v) where +instance (T.Print k, T.Print v) => T.Print (FlatMap k v) where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP p (FlatMap vec) = T.parenWhen (p > 10) $ do "FlatMap{" @@ -184,7 +184,7 @@ | otherwise -> Nothing | i > j = Nothing | otherwise = - let mid = (i+j) `shiftR` 1 + let mid = (i+j) `unsafeShiftR` 1 (k, v) = arr `A.indexSmallArray` mid in case k' `compare` k of LT -> go i (mid-1) GT -> go (mid+1) j @@ -351,7 +351,7 @@ _ -> Right i | i > j = Left i | otherwise = - let !mid = (i+j) `shiftR` 1 + let !mid = (i+j) `unsafeShiftR` 1 (k, _) = arr `A.indexSmallArray` mid in case k' `compare` k of LT -> go i (mid-1) GT -> go (mid+1) j 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 @@ -35,8 +35,8 @@ 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.ShowT as T -import Data.Bits (shiftR) +import qualified Z.Data.Text.Print as T +import Data.Bits (unsafeShiftR) import Data.Data import Prelude hiding (elem, null) import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) @@ -46,7 +46,7 @@ newtype FlatSet v = FlatSet { sortedValues :: V.Vector v } deriving (Show, Eq, Ord, Typeable, Foldable) -instance T.ShowT v => T.ShowT (FlatSet v) where +instance T.Print v => T.Print (FlatSet v) where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP p (FlatSet vec) = T.parenWhen (p > 10) $ do "FlatSet{" @@ -212,7 +212,7 @@ _ -> Right (s-s0) | s > e = Left s | otherwise = - let !mid = (s+e) `shiftR` 1 + let !mid = (s+e) `unsafeShiftR` 1 v = arr `A.indexSmallArray` mid in case v' `compare` v of LT -> go s (mid-1) GT -> go (mid+1) e diff --git a/Z/Data/Vector/Hex.hs b/Z/Data/Vector/Hex.hs --- a/Z/Data/Vector/Hex.hs +++ b/Z/Data/Vector/Hex.hs @@ -34,7 +34,7 @@ import qualified Z.Data.Vector.Base as V import qualified Z.Data.Builder.Base as B import qualified Z.Data.Text.Base as T -import qualified Z.Data.Text.ShowT as T +import qualified Z.Data.Text.Print as T import qualified Z.Data.JSON as JSON import Z.Foreign @@ -46,7 +46,7 @@ instance Show HexBytes where show (HexBytes bs) = T.unpack $ hexEncodeText True bs -instance T.ShowT HexBytes where +instance T.Print HexBytes where {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP _ (HexBytes bs) = B.quotes (hexEncodeBuilder True bs) diff --git a/Z/Foreign.hs b/Z/Foreign.hs --- a/Z/Foreign.hs +++ b/Z/Foreign.hs @@ -1,6 +1,6 @@ {-| Module : Z.Foreign -Description : Use PrimArray with FFI +Description : Use PrimArray \/ PrimVector with FFI Copyright : (c) Dong Han, 2017-2018 License : BSD Maintainer : winterland1989@gmail.com @@ -84,11 +84,16 @@ , StdString, fromStdString -- ** re-export , RealWorld + , touch , module Data.Primitive.ByteArray , module Data.Primitive.PrimArray , module Foreign.C.Types , module Data.Primitive.Ptr , module Z.Data.Array.Unaligned + -- ** Internal helpers + , hs_std_string_size + , hs_copy_std_string + , hs_delete_std_string ) where import Control.Exception (bracket) @@ -477,9 +482,9 @@ fromStdString f = bracket f hs_delete_std_string (\ q -> do siz <- hs_std_string_size q - (bs,_) <- allocBytesUnsafe siz (hs_copy_std_string q) + (bs,_) <- allocBytesUnsafe siz (hs_copy_std_string q siz) return bs) foreign import ccall unsafe hs_std_string_size :: Ptr StdString -> IO Int -foreign import ccall unsafe hs_copy_std_string :: Ptr StdString -> MBA# Word8 -> IO () +foreign import ccall unsafe hs_copy_std_string :: Ptr StdString -> Int -> MBA# Word8 -> IO () foreign import ccall unsafe hs_delete_std_string :: Ptr StdString -> IO () diff --git a/cbits/regex.cc b/cbits/regex.cc --- a/cbits/regex.cc +++ b/cbits/regex.cc @@ -58,12 +58,12 @@ else return 0; } -void hs_copy_std_string(std::string* str, char* buf) { - if (str != NULL) memcpy(buf, str->c_str(), str->size()); +void hs_copy_std_string(std::string* str, HsInt siz, char* buf) { + if (str != NULL) memcpy(buf, str->c_str(), siz); } void hs_delete_std_string(std::string* str) { - if (str != NULL) delete str; + delete str; } std::string* hs_re2_quote_meta(const char *in, HsInt off, HsInt len) { diff --git a/test/Z/Data/Array/UnalignedSpec.hs b/test/Z/Data/Array/UnalignedSpec.hs --- a/test/Z/Data/Array/UnalignedSpec.hs +++ b/test/Z/Data/Array/UnalignedSpec.hs @@ -292,3 +292,61 @@ (ByteArray ba#) <- unsafeFreezeByteArray mba let (BE w'') = indexWord8ArrayAs# ba# 7# return $ (w === w') .&&. (w === w'') + +-------------------------------------------------------------------------------- + + prop "roundtrip (,)" $ \ (w::(Word32,Word64)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,)" $ \ (w::(Word32,Word64,Word32)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,,)" $ \ (w::(Word32,Word64,Word32,Word64)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,,,)" $ \ (w::(Word32,Word64,Word32,Word64,Word32)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,,,,)" $ \ (w::(Word32,Word64,Word32,Word64,Word32,Word64)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,,,,,)" $ \ (w::(Word32,Word64,Word32,Word64,Word32,Word64,Word32)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip (,,,,,,,)" $ \ (w::(Word32,Word64,Word32,Word64,Word32,Word64,Word32,Word64)) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (w)) + (w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') diff --git a/test/Z/Data/Builder/TimeSpec.hs b/test/Z/Data/Builder/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Builder/TimeSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Data.Builder.TimeSpec where + +import qualified Data.List as List +import Data.Word +import Data.Int +import GHC.Float +import Data.Time.Format +import qualified Z.Data.Builder.Time as B +import qualified Z.Data.Builder.Base as B +import qualified Z.Data.Text as T +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.QuickCheck.Instances.Time +import Test.Hspec +import Test.Hspec.QuickCheck +import Data.Time.LocalTime + +spec :: Spec +spec = describe "builder time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do + describe "utcTime === format" $ do + prop "utcTime === format" $ \ t -> + (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.utcTime t) + + describe "localTime === format" $ do + prop "localTime === format" $ \ t -> + (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" t) === (T.unpack . B.buildText $ B.localTime t) + + describe "zonedTime === format" $ do + prop "zonedTime === format" $ \ t0 z0 -> + let z = abs z0 `div` 1440 + t = ZonedTime t0 (minutesToTimeZone z) + in if z == 0 + then (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" t) === (T.unpack . B.buildText $ B.zonedTime t) + else (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" t) === (T.unpack . B.buildText $ B.zonedTime t) diff --git a/test/Z/Data/JSON/ValueSpec.hs b/test/Z/Data/JSON/ValueSpec.hs --- a/test/Z/Data/JSON/ValueSpec.hs +++ b/test/Z/Data/JSON/ValueSpec.hs @@ -7,7 +7,6 @@ import Data.Word import Data.Int import GHC.Float -import Data.Word8 (toLower, toUpper) import qualified Z.Data.Builder as B import Test.QuickCheck import Test.QuickCheck.Function diff --git a/test/Z/Data/Parser/BaseSpec.hs b/test/Z/Data/Parser/BaseSpec.hs --- a/test/Z/Data/Parser/BaseSpec.hs +++ b/test/Z/Data/Parser/BaseSpec.hs @@ -8,7 +8,8 @@ import Data.Int import GHC.Float import Text.Printf (printf) -import Data.Word8 (toLower, toUpper) +import Data.Char (toLower) +import Z.Data.ASCII (w2c, c2w) import qualified Z.Data.Parser.Base as P import qualified Z.Data.Text as T import qualified Z.Data.Vector.Base as V @@ -98,7 +99,7 @@ parse'' (P.bytesCI . V.pack $ t) (t ++ s) === Just (V.pack s, ()) prop "bytesCI" $ \ s t -> - parse'' (P.bytesCI . V.pack $ t) (L.map toLower t ++ s) === Just (V.pack s, ()) + parse'' (P.bytesCI . V.pack $ t) (L.map (c2w . toLower . w2c) t ++ s) === Just (V.pack s, ()) prop "atEnd" $ \ s -> parse' P.atEnd s === diff --git a/test/Z/Data/Parser/NumericSpec.hs b/test/Z/Data/Parser/NumericSpec.hs --- a/test/Z/Data/Parser/NumericSpec.hs +++ b/test/Z/Data/Parser/NumericSpec.hs @@ -8,7 +8,6 @@ import Data.Int import GHC.Float import Text.Printf (printf) -import Data.Word8 (toLower, toUpper) import qualified Z.Data.Parser.Numeric as P import qualified Z.Data.Parser.Base as P import qualified Z.Data.Builder.Numeric as B diff --git a/test/Z/Data/Parser/TimeSpec.hs b/test/Z/Data/Parser/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Parser/TimeSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Data.Parser.TimeSpec where + +import qualified Data.List as List +import Data.Word +import Data.Int +import GHC.Float +import Data.Time.Format +import qualified Z.Data.Builder as B +import qualified Z.Data.Parser as P +import qualified Z.Data.Text as T +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.QuickCheck.Instances.Time +import Test.Hspec +import Test.Hspec.QuickCheck +import Data.Time.LocalTime + +spec :: Spec +spec = describe "parser time" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do + describe "utcTime roundtrip" $ do + prop "utcTime roundtrip" $ \ t -> + Right t === (P.parse' P.utcTime . B.build $ B.utcTime t) + + describe "localTime roundtrip" $ do + prop "localTime roundtrip" $ \ t -> + Right t === (P.parse' P.localTime . B.build $ B.localTime t) + + describe "zonedTime roundtrip" $ do + prop "zonedTime roundtrip" $ \ t0 z0 -> + let z = abs z0 `div` 1440 + t = ZonedTime t0 (minutesToTimeZone z) + in (zonedTimeToUTC <$> Right t) === (zonedTimeToUTC <$> (P.parse' P.zonedTime . B.build $ B.zonedTime t)) diff --git a/test/Z/Data/Text/PrintSpec.hs b/test/Z/Data/Text/PrintSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Text/PrintSpec.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Z.Data.Text.PrintSpec 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.Print +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, Print, Generic) + +data I a = I a :+ I a | I a :- I a | J a deriving (Show, Generic, Print) +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/ShowTSpec.hs b/test/Z/Data/Text/ShowTSpec.hs deleted file mode 100644 --- a/test/Z/Data/Text/ShowTSpec.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# 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" $ - 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/Vector/BaseSpec.hs b/test/Z/Data/Vector/BaseSpec.hs --- a/test/Z/Data/Vector/BaseSpec.hs +++ b/test/Z/Data/Vector/BaseSpec.hs @@ -7,12 +7,13 @@ import qualified Data.List as List import Data.Word import Data.Hashable (hashWithSalt, hash) -import qualified Z.Data.Vector.Base as V import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Property import Test.Hspec import Test.Hspec.QuickCheck +import qualified Z.Data.Vector.Base as V +import Z.Data.ASCII spec :: Spec spec = describe "vector-base" $ do @@ -75,9 +76,9 @@ describe "Bytes IsString instance property" $ do prop "ASCII string" $ - "hello world" === V.pack @V.PrimVector (List.map V.c2w "hello world") + "hello world" === V.pack @V.PrimVector (List.map c2w "hello world") prop "UTF8 string" $ - "你好世界" === V.pack @V.PrimVector (List.map V.c2w "你好世界") + "你好世界" === V.pack @V.PrimVector (List.map c2w "你好世界") describe "vector length == List.length" $ do prop "vector length === List.length" $ \ xs -> diff --git a/test/Z/Data/Vector/ExtraSpec.hs b/test/Z/Data/Vector/ExtraSpec.hs --- a/test/Z/Data/Vector/ExtraSpec.hs +++ b/test/Z/Data/Vector/ExtraSpec.hs @@ -5,14 +5,15 @@ import qualified Data.List as List import Data.Word -import qualified Z.Data.Vector as V -import qualified Z.Data.Vector.Base as V -import qualified Z.Data.Vector.Extra as V import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Property import Test.Hspec import Test.Hspec.QuickCheck +import Z.Data.ASCII +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V spec :: Spec spec = describe "vector-extras" $ do @@ -356,22 +357,22 @@ describe "vector words == List.words" $ do prop "vector words === List.words" $ \ xs -> (V.words . V.pack @V.PrimVector @Word8 $ xs) === - (V.pack . List.map V.c2w <$> (List.words . List.map V.w2c $ xs)) + (V.pack . List.map c2w <$> (List.words . List.map w2c $ xs)) describe "vector lines == List.lines" $ do prop "vector lines === List.lines" $ \ xs -> (V.lines . V.pack @V.PrimVector @Word8 $ xs) === - (V.pack . List.map V.c2w <$> (List.lines . List.map V.w2c $ xs)) + (V.pack . List.map c2w <$> (List.lines . List.map w2c $ xs)) describe "vector unwords == List.unwords" $ do prop "vector unwords === List.unwords" $ \ xs -> (V.unwords $ V.pack @V.PrimVector @Word8 <$> xs) === - (V.pack (List.map V.c2w . List.unwords $ List.map V.w2c <$> xs)) + (V.pack (List.map c2w . List.unwords $ List.map w2c <$> xs)) describe "vector unlines == List.unlines" $ do prop "vector unlines === List.unlines" $ \ (NonEmpty xs) -> ((V.unlines $ V.pack @V.PrimVector @Word8 <$> xs) <> V.singleton 10) === - (V.pack (List.map V.c2w . List.unlines $ List.map V.w2c <$> xs)) + (V.pack (List.map c2w . List.unlines $ List.map w2c <$> xs)) describe "vector padLeft n x xs = if l >= n then xs else replicate (n-l) x ++ xs" $ do prop "vector padLeft n x xs = if l >= n then xs else replicate (n-l) x ++ xs" $ \ xs n x ->