QuickCheck tests for date/time types and numeric

Author: VyacheslavHashov

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

@@ -3,8 +3,8 @@ module Database.PostgreSQL.Protocol.Codecs.Decoders where
 import Data.Word
 import Data.Int
 import Data.Maybe
-import Data.Fixed
 import Data.Char
+import Data.Scientific
 import Data.UUID (UUID, fromWords)
 import Data.Time (Day, UTCTime, LocalTime, DiffTime)
 import qualified Data.ByteString as B
@@ -94,7 +94,7 @@ char _ = chr . fromIntegral <$> getWord8
 
 {-# INLINE date #-}
 date :: FieldDecoder Day
-date _ = pgjToDay <$> getWord32BE
+date _ = pgjToDay <$> getInt32BE
 
 {-# INLINE float4 #-}
 float4 :: FieldDecoder Float
@@ -130,15 +130,15 @@ bsJsonText = getByteString
 bsJsonBytes :: FieldDecoder B.ByteString
 bsJsonBytes len = getWord8 *> getByteString (len - 1)
 
-numeric :: HasResolution a => FieldDecoder (Fixed a)
-numeric _ = do
-   ndigits <- getWord16BE
-   weight <- getInt16BE
-   msign <- numericSign <$> getWord16BE
-   sign <- maybe (fail "unknown numeric") pure msign
-   dscale <- getWord16BE
-   digits <- replicateM (fromIntegral ndigits) getWord16BE
-   pure $ undefined
+{-# INLINE numeric #-}
+numeric :: FieldDecoder Scientific
+numeric _ = do 
+    ndigits <- getWord16BE
+    weight <- getInt16BE
+    sign <- getWord16BE >>= fromNumericSign
+    _ <- getWord16BE
+    numericToScientific sign weight <$> 
+        replicateM (fromIntegral ndigits) getWord16BE
 
 -- | Decodes text without applying encoding.
 {-# INLINE bsText #-}
@@ -147,11 +147,11 @@ bsText = getByteString
 
 {-# INLINE timestamp #-}
 timestamp :: FieldDecoder LocalTime
-timestamp _ = microsToLocalTime <$> getWord64BE
+timestamp _ = microsToLocalTime <$> getInt64BE
 
 {-# INLINE timestamptz #-}
 timestamptz :: FieldDecoder UTCTime
-timestamptz _ = microsToUTC <$> getWord64BE
+timestamptz _ = microsToUTC <$> getInt64BE
 
 {-# INLINE uuid #-}
 uuid :: FieldDecoder UUID

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

@@ -4,8 +4,8 @@ import Data.Word
 import Data.Monoid ((<>))
 import Data.Int
 import Data.Char
-import Data.Fixed
-import Data.UUID (UUID, toByteString)
+import Data.Scientific
+import Data.UUID (UUID, toWords)
 import Data.Time (Day, UTCTime, LocalTime, DiffTime)
 import qualified Data.ByteString as B
 import qualified Data.Vector as V
@@ -35,7 +35,7 @@ char = putWord8 . fromIntegral . ord
 
 {-# INLINE date #-}
 date :: Day -> Encode
-date = putWord32BE . dayToPgj
+date = putInt32BE . dayToPgj
 
 {-# INLINE float4 #-}
 float4 :: Float -> Encode
@@ -72,15 +72,15 @@ bsJsonText = putByteString
 bsJsonBytes :: B.ByteString -> Encode
 bsJsonBytes bs = putWord8 1 <> putByteString bs
 
-numeric :: HasResolution a => (Fixed a) -> Encode
-numeric _ = do undefined
-   -- ndigits <- putWord16BE
-   -- weight <- putInt16BE
-   -- msign <- numericSign <$> putWord16BE
-   -- sign <- maybe (fail "unknown numeric") pure msign
-   -- dscale <- putWord16BE
-   -- digits <- replicateM (fromIntegral ndigits) putWord16BE
-   -- pure $ undefined
+{-# INLINE numeric #-}
+numeric :: Scientific -> Encode
+numeric n = 
+    let (weight, scale, digits) = scientificToNumeric n
+    in    putWord16BE (fromIntegral $ length digits)
+       <> putInt16BE weight
+       <> putWord16BE (toNumericSign n)
+       <> putWord16BE scale
+       <> foldMap putWord16BE digits
 
 -- | Encodes text.
 {-# INLINE bsText #-}
@@ -89,12 +89,13 @@ bsText = putByteString
 
 {-# INLINE timestamp #-}
 timestamp :: LocalTime -> Encode
-timestamp = putWord64BE . localTimeToMicros 
+timestamp = putInt64BE . localTimeToMicros 
 
 {-# INLINE timestamptz #-}
 timestamptz :: UTCTime -> Encode
-timestamptz = putWord64BE . utcToMicros 
+timestamptz = putInt64BE . utcToMicros 
 
 {-# INLINE uuid #-}
 uuid :: UUID -> Encode
-uuid = undefined
+uuid v = let (a, b, c, d) = toWords v 
+         in putWord32BE a <> putWord32BE b <> putWord32BE c <> putWord32BE d

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

@@ -1,21 +1,51 @@
+{-# 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.Fixed
+import Data.Scientific
+import Data.List (unfoldr)
 
-numericDigit :: [Word16] -> Integer
-numericDigit = foldl' (\acc n -> acc * nBase + fromIntegral n) 0
+integerToDigits :: Integer -> [Word16]
+integerToDigits = (reverse.) . unfoldr $ \case 
+    0 -> Nothing
+    n -> let (rest, rem) =  n `divMod` nBase in Just (fromIntegral rem, rest)
 
-numericSign :: Num a => Word16 -> Maybe a
-numericSign 0x0000 = Just 1
-numericSign 0x4000 = Just $ -1
-numericSign _      = Nothing  -- NaN code is 0xC000, it is not supported.
+toNumericSign :: Scientific -> Word16
+toNumericSign s | s >= 0 = 0x0000
+              | otherwise = 0x4000
 
-fixedFromNumeric :: HasResolution a => Int16 -> [Word16] -> Fixed a
-fixedFromNumeric weight digits = undefined
+scientificToNumeric :: Scientific -> (Int16, Word16, [Word16])
+scientificToNumeric number = 
+    let a       = base10Exponent number `mod` nBaseDigits
+        adjExp  = base10Exponent number - a
+        adjCoef = coefficient number * (10 ^ a)
+        digits  = integerToDigits $ abs adjCoef
+        weight  = fromIntegral $ length digits + adjExp `div` nBaseDigits - 1
+        scale   = fromIntegral . negate $ min (base10Exponent number) 0
+    in (weight, scale, digits)
+
+digitsToInteger :: [Word16] -> Integer
+digitsToInteger = foldl' (\acc n -> acc * nBase + fromIntegral n) 0
+
+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' 
 
 nBase :: Num a => a
 nBase = 10000
+
+nBaseDigits :: Num a => a
+nBaseDigits = 4
+

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

@@ -9,8 +9,7 @@ module Database.PostgreSQL.Protocol.Codecs.Time
     , diffTimeToInterval
     ) where
 
-import Data.Int  (Int64, Int32)
-import Data.Word (Word32, Word64)
+import Data.Int  (Int64, Int32, Int64)
 import Data.Time (Day(..), UTCTime(..), LocalTime(..), DiffTime, TimeOfDay,
                   picosecondsToDiffTime, timeToTimeOfDay,
                   diffTimeToPicoseconds, timeOfDayToTime)
@@ -21,11 +20,11 @@ dayToPgj = fromIntegral
     .(+ (modifiedJulianEpoch - postgresEpoch)) . toModifiedJulianDay
 
 {-# INLINE utcToMicros #-}
-utcToMicros :: UTCTime -> Word64
+utcToMicros :: UTCTime -> Int64
 utcToMicros (UTCTime day diffTime) = dayToMcs day + diffTimeToMcs diffTime
 
 {-# INLINE localTimeToMicros #-}
-localTimeToMicros :: LocalTime -> Word64
+localTimeToMicros :: LocalTime -> Int64
 localTimeToMicros (LocalTime day time) = dayToMcs day + timeOfDayToMcs time
 
 {-# INLINE pgjToDay #-}
@@ -34,13 +33,13 @@ pgjToDay = ModifiedJulianDay . fromIntegral
                         . subtract (modifiedJulianEpoch - postgresEpoch)
 
 {-# INLINE microsToUTC #-}
-microsToUTC :: Word64 -> UTCTime
+microsToUTC :: Int64 -> UTCTime
 microsToUTC mcs =
     let (d, r) = mcs `divMod` microsInDay
     in UTCTime (pgjToDay d) (mcsToDiffTime r)
 
 {-# INLINE microsToLocalTime #-}
-microsToLocalTime :: Word64 -> LocalTime
+microsToLocalTime :: Int64 -> LocalTime
 microsToLocalTime mcs =
     let (d, r) = mcs `divMod` microsInDay
     in LocalTime (pgjToDay d) (mcsToTimeOfDay r)
@@ -87,14 +86,18 @@ pcsToMcs = (`div` 10 ^ 6)
 mcsToPcs :: Integral a => a -> a
 mcsToPcs = (* 10 ^ 6)
 
+{-# INLINE modifiedJulianEpoch #-}
 modifiedJulianEpoch :: Num a => a 
 modifiedJulianEpoch = 2400001
 
+{-# INLINE postgresEpoch #-}
 postgresEpoch :: Num a => a
 postgresEpoch = 2451545
 
+{-# INLINE microsInDay #-}
 microsInDay :: Num a => a
 microsInDay = 24 * 60 * 60 * 10 ^ 6
 
+{-# INLINE daysInMonth #-}
 daysInMonth :: Num a => a
 daysInMonth = 30