diff --git a/library/PostgreSQLBinary/Decoder.hs b/library/PostgreSQLBinary/Decoder.hs --- a/library/PostgreSQLBinary/Decoder.hs +++ b/library/PostgreSQLBinary/Decoder.hs @@ -10,7 +10,6 @@ import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Scientific as Scientific import qualified Data.UUID as UUID -import qualified PostgreSQLBinary.Decoder.Atto as Atto import qualified PostgreSQLBinary.Decoder.Zepto as Zepto import qualified PostgreSQLBinary.Array as Array import qualified PostgreSQLBinary.Time as Time @@ -47,24 +46,7 @@ {-# INLINABLE numeric #-} numeric :: D Scientific numeric = - evalStateT $ do - componentsAmount <- intOfSize 2 - pointIndex :: Int16 <- intOfSize 2 - signCode <- intOfSize 2 - modify (B.drop 2) - components <- replicateM componentsAmount (intOfSize 2) - signer <- - if | signCode == Numeric.negSignCode -> return negate - | signCode == Numeric.posSignCode -> return id - | signCode == Numeric.nanSignCode -> lift $ Left "NAN sign" - | otherwise -> lift $ Left $ "Unexpected sign value: " <> (fromString . show) signCode - let - c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64) - e = (fromIntegral (pointIndex + 1) - length components) * 4 - in return $ Scientific.scientific c e - where - intOfSize n = - lift . int =<< state (B.splitAt n) + flip Zepto.run (inline Zepto.numeric) -- * Text diff --git a/library/PostgreSQLBinary/Decoder/Atto.hs b/library/PostgreSQLBinary/Decoder/Atto.hs deleted file mode 100644 --- a/library/PostgreSQLBinary/Decoder/Atto.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | --- Composable Attoparsec parsers. -module PostgreSQLBinary.Decoder.Atto where - -import PostgreSQLBinary.Prelude hiding (take, bool) -import Data.Attoparsec.ByteString -import Data.Attoparsec.ByteString.Char8 hiding (double) -import qualified PostgreSQLBinary.Integral as Integral -import qualified PostgreSQLBinary.Array as Array -import qualified Data.Scientific as Scientific - - -{-# INLINABLE run #-} -run :: ByteString -> Parser a -> Either Text a -run input parser = - onResult $ parse (parser <* endOfInput) input - where - onResult = - \case - Fail remainder contexts message -> - Left $ "Message: " <> (fromString . show) message <> "; " <> - "Contexts: " <> (fromString . show) contexts <> "; " <> - "Failing input: " <> (fromString . show) remainder - Partial c -> - onResult $ c mempty - Done _ result -> - Right result - -{-# INLINE integral #-} -integral :: forall a. (Integral a, Bits a) => Parser a -integral = - intOfSize (Integral.byteSize (undefined :: a)) - -{-# INLINE intOfSize #-} -intOfSize :: (Integral a, Bits a) => Int -> Parser a -intOfSize x = - Integral.pack <$> take x - -bool :: Parser Bool -bool = - (word8 0 *> pure False) <|> (word8 1 *> pure True) - -double :: Parser Double -double = - unsafeCoerce (intOfSize 8 :: Parser Int64) diff --git a/library/PostgreSQLBinary/Decoder/Zepto.hs b/library/PostgreSQLBinary/Decoder/Zepto.hs --- a/library/PostgreSQLBinary/Decoder/Zepto.hs +++ b/library/PostgreSQLBinary/Decoder/Zepto.hs @@ -6,6 +6,7 @@ import Data.Attoparsec.Zepto import qualified PostgreSQLBinary.Integral as Integral import qualified PostgreSQLBinary.Array as Array +import qualified PostgreSQLBinary.Numeric as Numeric import qualified Data.Scientific as Scientific @@ -50,3 +51,21 @@ 1 -> return True w -> fail $ "Invalid value: " <> show w +{-# INLINE numeric #-} +numeric :: Parser Scientific +numeric = + do + componentsAmount <- intOfSize 2 + pointIndex :: Int16 <- intOfSize 2 + signCode <- intOfSize 2 + take 2 + components <- replicateM componentsAmount (intOfSize 2) + signer <- + if | signCode == Numeric.negSignCode -> return negate + | signCode == Numeric.posSignCode -> return id + | signCode == Numeric.nanSignCode -> fail "NAN sign" + | otherwise -> fail $ "Unexpected sign value: " <> show signCode + let + c = signer $ fromIntegral $ (Numeric.mergeComponents components :: Word64) + e = (fromIntegral (pointIndex + 1) - length components) * 4 + in return $ Scientific.scientific c e diff --git a/library/PostgreSQLBinary/Interval.hs b/library/PostgreSQLBinary/Interval.hs --- a/library/PostgreSQLBinary/Interval.hs +++ b/library/PostgreSQLBinary/Interval.hs @@ -16,7 +16,7 @@ -- | -- Oddly enough despite a claim of support of up to 178000000 years in -- --- in practice it starts behaving unpredictable after a smaller limit. +-- in practice it starts behaving unpredictably after a smaller limit. maxDiffTime :: DiffTime = 1780000 * Time.microsToDiffTime Time.year minDiffTime :: DiffTime = negate maxDiffTime @@ -39,5 +39,5 @@ toDiffTime x = picosecondsToDiffTime $ (10 ^ 6) * - (fromIntegral (micros x) + - 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) + (fromIntegral (micros x) + + 10 ^ 6 * 60 * 60 * 24 * (fromIntegral (days x + 31 * months x))) diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,7 +1,7 @@ name: postgresql-binary version: - 0.2.2 + 0.2.3 synopsis: Encoders and decoders for the PostgreSQL's binary format description: @@ -51,7 +51,6 @@ other-modules: PostgreSQLBinary.Prelude PostgreSQLBinary.Encoder.Builder - PostgreSQLBinary.Decoder.Atto PostgreSQLBinary.Decoder.Zepto PostgreSQLBinary.Integral PostgreSQLBinary.Numeric @@ -74,7 +73,7 @@ loch-th == 0.2.*, placeholders == 0.1.*, -- general: - mtl-prelude == 2.0.*, + mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8 @@ -140,7 +139,7 @@ bytestring >= 0.10 && < 0.11, -- general: deepseq == 1.3.*, - mtl-prelude == 2.0.*, + mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8 @@ -172,6 +171,6 @@ bytestring >= 0.10 && < 0.11, -- general: deepseq == 1.3.*, - mtl-prelude == 2.0.*, + mtl-prelude < 3, base-prelude >= 0.1.3 && < 0.2, base >= 4.5 && < 4.8