Refactor numeric tests

Author: VyacheslavHashov

postgres-wire.cabal

@@ -99,6 +99,9 @@ test-suite postgres-wire-test
                      , tasty-hunit
                      , tasty-quickcheck
                      , QuickCheck >= 2.9
+                     , scientific
+                     , time
+                     , uuid
                      , tagged
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010

src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs

@@ -24,7 +24,7 @@ import Database.PostgreSQL.Protocol.Codecs.Numeric
 -- 2 bytes - count of columns in the DataRow
 {-# INLINE dataRowHeader #-}
 dataRowHeader :: Decode ()
-dataRowHeader  = skipBytes 7
+dataRowHeader = skipBytes 7
 
 {-# INLINE fieldLength #-}
 fieldLength :: Decode Int
@@ -73,13 +73,13 @@ arrayDimensions dims = V.reverse <$> V.replicateM dims arrayDimSize
 arrayFieldDecoder :: Int -> (V.Vector Int -> Decode a) -> FieldDecoder a
 arrayFieldDecoder dims f _ = arrayHeader *> arrayDimensions dims >>= f
 
--- | Decodes only a content of the field.
-type FieldDecoder a = Int -> Decode a 
-
 --
 -- Primitives
 --
 
+-- | Decodes only a content of the field.
+type FieldDecoder a = Int -> Decode a 
+
 {-# INLINE bool #-}
 bool :: FieldDecoder Bool
 bool _ = (== 1) <$> getWord8
@@ -134,9 +134,9 @@ bsJsonBytes len = getWord8 *> getByteString (len - 1)
 numeric :: FieldDecoder Scientific
 numeric _ = do 
     ndigits <- getWord16BE
-    weight <- getInt16BE
-    sign <- getWord16BE >>= fromNumericSign
-    _ <- getWord16BE
+    weight  <- getInt16BE
+    sign    <- fromNumericSign =<< getWord16BE 
+    _       <- getWord16BE
     numericToScientific sign weight <$> 
         replicateM (fromIntegral ndigits) getWord16BE
 

src/Database/PostgreSQL/Protocol/Codecs/Encoders.hs

@@ -16,6 +16,7 @@ import Database.PostgreSQL.Protocol.Store.Encode
 import Database.PostgreSQL.Protocol.Types
 import Database.PostgreSQL.Protocol.Codecs.Time
 import Database.PostgreSQL.Protocol.Codecs.Numeric
+
 --
 -- Primitives
 --
@@ -59,7 +60,7 @@ int8 = putInt64BE
 
 {-# INLINE interval #-}
 interval :: DiffTime -> Encode
-interval v = let (mcs, days, months)  = diffTimeToInterval v 
+interval v = let (mcs, days, months) = diffTimeToInterval v 
              in putInt64BE mcs <> putInt32BE days <> putInt32BE months
 
 -- | Encodes representation of JSON as @ByteString@.

src/Database/PostgreSQL/Protocol/Codecs/Numeric.hs

@@ -1,23 +1,14 @@
 {-# language LambdaCase #-}
-module Database.PostgreSQL.Protocol.Codecs.Numeric where
-
--- TODO test it
-import Data.Tuple
-import Data.Word
-import Data.Int
-import Data.Foldable
-import Data.Scientific
-import Data.List (unfoldr)
 
-integerToDigits :: Integer -> [Word16]
-integerToDigits = (reverse.) . unfoldr $ \case 
-    0 -> Nothing
-    n -> let (rest, rem) =  n `divMod` nBase in Just (fromIntegral rem, rest)
+module Database.PostgreSQL.Protocol.Codecs.Numeric where
 
-toNumericSign :: Scientific -> Word16
-toNumericSign s | s >= 0 = 0x0000
-              | otherwise = 0x4000
+import Data.Word       (Word16)
+import Data.Int        (Int16)
+import Data.Foldable   (foldl')
+import Data.Scientific (Scientific, scientific, base10Exponent, coefficient)
+import Data.List       (unfoldr)
 
+{-# INLINE scientificToNumeric #-}
 scientificToNumeric :: Scientific -> (Int16, Word16, [Word16])
 scientificToNumeric number = 
     let a       = base10Exponent number `mod` nBaseDigits
@@ -28,24 +19,40 @@ scientificToNumeric number =
         scale   = fromIntegral . negate $ min (base10Exponent number) 0
     in (weight, scale, digits)
 
-digitsToInteger :: [Word16] -> Integer
-digitsToInteger = foldl' (\acc n -> acc * nBase + fromIntegral n) 0
+{-# INLINE numericToScientific #-}
+numericToScientific :: Integer -> Int16 -> [Word16] -> Scientific
+numericToScientific sign weight digits = 
+    let coef = digitsToInteger digits * sign
+        exp' = (fromIntegral weight + 1 - length digits) * nBaseDigits
+    in scientific coef exp' 
 
+{-# INLINE toNumericSign #-}
+toNumericSign :: Scientific -> Word16
+toNumericSign s | s >= 0    = 0x0000
+                | otherwise = 0x4000
+
+{-# INLINE fromNumericSign #-}
 fromNumericSign :: (Monad m, Num a) => Word16 -> m a
 fromNumericSign 0x0000 = pure 1
 fromNumericSign 0x4000 = pure $ -1
 -- NaN code is 0xC000, it is not supported.
 fromNumericSign _      = fail "Unknown numeric sign"  
 
-numericToScientific :: Integer -> Int16 -> [Word16] -> Scientific
-numericToScientific sign weight digits = 
-    let coef = digitsToInteger digits * sign
-        exp' = (fromIntegral weight + 1 - length digits) * nBaseDigits
-    in scientific coef exp' 
+{-# INLINE integerToDigits #-}
+integerToDigits :: Integer -> [Word16]
+integerToDigits = (reverse.) . unfoldr $ \case 
+    0 -> Nothing
+    n -> let (rest, rem) =  n `divMod` nBase in Just (fromIntegral rem, rest)
+
+{-# INLINE digitsToInteger #-}
+digitsToInteger :: [Word16] -> Integer
+digitsToInteger = foldl' (\acc n -> acc * nBase + fromIntegral n) 0
 
+{-# INLINE nBase #-}
 nBase :: Num a => a
 nBase = 10000
 
+{-# INLINE nBaseDigits #-}
 nBaseDigits :: Num a => a
 nBaseDigits = 4
 

tests/Codecs/QuickCheck.hs

@@ -65,9 +65,7 @@ makeCodecEncodeProperty c oid queryString encoder fPrint v = monadicIO $ do
         sendBatchAndSync c [q]
         dr <- readNextData c
         waitReadyForQuery c
-        r <- either (error . show) (pure . BC.unpack . decodeOneRow decoder) dr
-        -- print $ fPrint v <> "  " <> r
-        pure r
+        either (error . show) (pure . BC.unpack . decodeOneRow decoder) dr
 
     assertQCEqual (fPrint v) r
 
@@ -96,7 +94,7 @@ mkCodecEncodeTest name oids queryString encoder fPrint =
 
 testCodecsEncodeDecode :: TestTree
 testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'"
-    [ {-mkCodecTest "bool" PGT.bool PE.bool PD.bool
+    [ mkCodecTest "bool" PGT.bool PE.bool PD.bool
     , mkCodecTest "bytea" PGT.bytea PE.bytea PD.bytea
     , mkCodecTest "char" PGT.char PE.char PD.char
     , mkCodecTest "date" PGT.date PE.date PD.date
@@ -110,12 +108,11 @@ testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'"
                                   (fmap JsonString <$> PD.bsJsonText)
     , mkCodecTest "jsonb" PGT.jsonb (PE.bsJsonBytes .unJsonString) 
                                     (fmap JsonString <$> PD.bsJsonBytes)
-    -- TODO
-    , -}mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric
-    {-, mkCodecTest "text" PGT.text PE.bsText PD.bsText
+    , mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric
+    , mkCodecTest "text" PGT.text PE.bsText PD.bsText
     , mkCodecTest "timestamp" PGT.timestamp PE.timestamp PD.timestamp
     , mkCodecTest "timestamptz" PGT.timestamptz PE.timestamptz PD.timestamptz
-    , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid-}
+    , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid
     ]
 
 testCodecsEncodePrint :: TestTree