module PostgreSQL.Binary.Numeric where

import PostgreSQL.Binary.Prelude
import qualified Data.Vector as Vector
import qualified Data.Scientific as Scientific


{-# INLINE posSignCode #-}
posSignCode :: Word16
posSignCode :: Word16
posSignCode = Word16
0x0000

{-# INLINE negSignCode #-}
negSignCode :: Word16
negSignCode :: Word16
negSignCode = Word16
0x4000

{-# INLINE nanSignCode #-}
nanSignCode :: Word16
nanSignCode :: Word16
nanSignCode = Word16
0xC000

{-# INLINE extractComponents #-}
extractComponents :: Integral a => a -> [Word16]
extractComponents :: a -> [Word16]
extractComponents =
  ([Word16] -> [Word16]
forall a. [a] -> [a]
reverse ([Word16] -> [Word16]) -> (a -> [Word16]) -> a -> [Word16]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.) ((a -> [Word16]) -> a -> [Word16])
-> ((a -> Maybe (Word16, a)) -> a -> [Word16])
-> (a -> Maybe (Word16, a))
-> a
-> [Word16]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((a -> [Word16]) -> (a -> a) -> a -> [Word16]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a
forall a. Num a => a -> a
abs) ((a -> [Word16]) -> a -> [Word16])
-> ((a -> Maybe (Word16, a)) -> a -> [Word16])
-> (a -> Maybe (Word16, a))
-> a
-> [Word16]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a -> Maybe (Word16, a)) -> a -> [Word16]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((a -> Maybe (Word16, a)) -> a -> [Word16])
-> (a -> Maybe (Word16, a)) -> a -> [Word16]
forall a b. (a -> b) -> a -> b
$ \case
    a
0 -> Maybe (Word16, a)
forall a. Maybe a
Nothing
    a
x -> case a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
divMod a
x a
10000 of
      (a
d, a
m) -> (Word16, a) -> Maybe (Word16, a)
forall a. a -> Maybe a
Just (a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
m, a
d)

{-# INLINE mergeComponents #-}
mergeComponents :: Integral a => Vector a -> Integer
mergeComponents :: Vector a -> Integer
mergeComponents = 
  (Integer -> a -> Integer) -> Integer -> Vector a -> Integer
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\Integer
l a
r -> Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
r) Integer
0

{-# INLINE mergeDigits #-}
mergeDigits :: Integral a => Vector a -> a
mergeDigits :: Vector a -> a
mergeDigits = 
  (a -> a -> a) -> a -> Vector a -> a
forall a b. (a -> b -> a) -> a -> Vector b -> a
Vector.foldl' (\a
l a
r -> a
l a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ a
r) a
0

-- |
-- Unpack a component into digits.
{-# INLINE componentDigits #-}
componentDigits :: Int16 -> [Int16]
componentDigits :: Int16 -> [Int16]
componentDigits =
  State Int16 [Int16] -> Int16 -> [Int16]
forall s a. State s a -> s -> a
evalState (State Int16 [Int16] -> Int16 -> [Int16])
-> State Int16 [Int16] -> Int16 -> [Int16]
forall a b. (a -> b) -> a -> b
$ do
    Int16
a <- (Int16 -> (Int16, Int16)) -> StateT Int16 Identity Int16
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int16 -> Int16 -> (Int16, Int16))
-> Int16 -> Int16 -> (Int16, Int16)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int16 -> Int16 -> (Int16, Int16)
forall a. Integral a => a -> a -> (a, a)
divMod Int16
1000)
    Int16
b <- (Int16 -> (Int16, Int16)) -> StateT Int16 Identity Int16
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int16 -> Int16 -> (Int16, Int16))
-> Int16 -> Int16 -> (Int16, Int16)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int16 -> Int16 -> (Int16, Int16)
forall a. Integral a => a -> a -> (a, a)
divMod Int16
100)
    Int16
c <- (Int16 -> (Int16, Int16)) -> StateT Int16 Identity Int16
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int16 -> Int16 -> (Int16, Int16))
-> Int16 -> Int16 -> (Int16, Int16)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int16 -> Int16 -> (Int16, Int16)
forall a. Integral a => a -> a -> (a, a)
divMod Int16
10)
    Int16
d <- StateT Int16 Identity Int16
forall (m :: * -> *) s. Monad m => StateT s m s
get
    [Int16] -> State Int16 [Int16]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int16] -> State Int16 [Int16]) -> [Int16] -> State Int16 [Int16]
forall a b. (a -> b) -> a -> b
$ [Int16
a, Int16
b, Int16
c, Int16
d]

{-# INLINABLE componentsReplicateM #-}
componentsReplicateM :: (Integral a, Applicative m) => Int -> m a -> m a
componentsReplicateM :: Int -> m a -> m a
componentsReplicateM Int
amount m a
component = 
  (m a -> m a -> m a) -> m a -> [m a] -> m a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' m a -> m a -> m a
forall (f :: * -> *) c. (Applicative f, Num c) => f c -> f c -> f c
folder (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0) (Int -> m a -> [m a]
forall a. Int -> a -> [a]
replicate Int
amount m a
component)
  where
    folder :: f c -> f c -> f c
folder f c
acc f c
component =
      (c -> c -> c) -> f c -> f c -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 c -> c -> c
forall a. Num a => a -> a -> a
(+) ((c -> c) -> f c -> f c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (c -> c -> c
forall a. Num a => a -> a -> a
*c
10000) f c
acc) f c
component

{-# INLINE signer #-}
signer :: Integral a => Word16 -> Either Text (a -> a)
signer :: Word16 -> Either Text (a -> a)
signer =
  \case
    Word16
0x0000 -> (a -> a) -> Either Text (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
    Word16
0x4000 -> (a -> a) -> Either Text (a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a
forall a. Num a => a -> a
negate
    Word16
0xC000 -> Text -> Either Text (a -> a)
forall a b. a -> Either a b
Left Text
"NAN sign"
    Word16
signCode -> Text -> Either Text (a -> a)
forall a b. a -> Either a b
Left (Text
"Unexpected sign code: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Word16 -> String) -> Word16 -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word16 -> String
forall a. Show a => a -> String
show) Word16
signCode)

{-# INLINE scientific #-}
scientific :: Int16 -> Word16 -> Vector Word16 -> Either Text Scientific
scientific :: Int16 -> Word16 -> Vector Word16 -> Either Text Scientific
scientific Int16
pointIndex Word16
signCode Vector Word16
components =
  do
    Integer -> Integer
theSigner <- Word16 -> Either Text (Integer -> Integer)
forall a. Integral a => Word16 -> Either Text (a -> a)
signer Word16
signCode
    Scientific -> Either Text Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Int -> Scientific
Scientific.scientific ((Integer -> Integer) -> Integer
c Integer -> Integer
theSigner) Int
e)
  where
    c :: (Integer -> Integer) -> Integer
c Integer -> Integer
signer =
      Integer -> Integer
signer (Vector Word16 -> Integer
forall a. Integral a => Vector a -> Integer
mergeComponents Vector Word16
components)
    e :: Int
e =
      (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
pointIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Vector Word16 -> Int
forall a. Vector a -> Int
Vector.length Vector Word16
components) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4