{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeOperators              #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Haspara.Internal.Quantity where

import           Control.Applicative        (liftA2)
import           Control.Monad.Except       (MonadError(throwError))
import qualified Data.Aeson                 as Aeson
import           Data.Either                (fromRight)
import           Data.Proxy                 (Proxy(..))
import qualified Data.Scientific            as S
import           GHC.Generics               (Generic)
import           GHC.TypeLits               (KnownNat, Nat, natVal, type (+))
import qualified Language.Haskell.TH.Syntax as TH
import qualified Numeric.Decimal            as D


-- $setup
-- >>> :set -XDataKinds


-- | Type encoding for common quantity values with given scaling (digits after
-- the decimal point).
--
-- >>> 42 :: Quantity 0
-- 42
-- >>> 42 :: Quantity 1
-- 42.0
-- >>> 42 :: Quantity 2
-- 42.00
-- >>> 41 + 1 :: Quantity 2
-- 42.00
-- >>> 43 - 1 :: Quantity 2
-- 42.00
-- >>> 2 * 3 * 7 :: Quantity 2
-- 42.00
-- >>> negate (-42) :: Quantity 2
-- 42.00
-- >>> abs (-42) :: Quantity 2
-- 42.00
-- >>> signum (-42) :: Quantity 2
-- -1.00
-- >>> fromInteger 42 :: Quantity 2
-- 42.00
-- >>> quantity 0.415 :: Quantity 2
-- 0.42
-- >>> quantity 0.425 :: Quantity 2
-- 0.42
-- >>> quantityLossless 0.42 :: Either String (Quantity 2)
-- Right 0.42
-- >>> quantityLossless 0.415 :: Either String (Quantity 2)
-- Left "Underflow while trying to create quantity: 0.415"
newtype Quantity (s :: Nat) = MkQuantity { Quantity s -> Decimal RoundHalfEven s Integer
unQuantity :: D.Decimal D.RoundHalfEven s Integer }
  deriving (Quantity s -> Quantity s -> Bool
(Quantity s -> Quantity s -> Bool)
-> (Quantity s -> Quantity s -> Bool) -> Eq (Quantity s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Nat). Quantity s -> Quantity s -> Bool
/= :: Quantity s -> Quantity s -> Bool
$c/= :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
== :: Quantity s -> Quantity s -> Bool
$c== :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
Eq, Eq (Quantity s)
Eq (Quantity s)
-> (Quantity s -> Quantity s -> Ordering)
-> (Quantity s -> Quantity s -> Bool)
-> (Quantity s -> Quantity s -> Bool)
-> (Quantity s -> Quantity s -> Bool)
-> (Quantity s -> Quantity s -> Bool)
-> (Quantity s -> Quantity s -> Quantity s)
-> (Quantity s -> Quantity s -> Quantity s)
-> Ord (Quantity s)
Quantity s -> Quantity s -> Bool
Quantity s -> Quantity s -> Ordering
Quantity s -> Quantity s -> Quantity s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (s :: Nat). Eq (Quantity s)
forall (s :: Nat). Quantity s -> Quantity s -> Bool
forall (s :: Nat). Quantity s -> Quantity s -> Ordering
forall (s :: Nat). Quantity s -> Quantity s -> Quantity s
min :: Quantity s -> Quantity s -> Quantity s
$cmin :: forall (s :: Nat). Quantity s -> Quantity s -> Quantity s
max :: Quantity s -> Quantity s -> Quantity s
$cmax :: forall (s :: Nat). Quantity s -> Quantity s -> Quantity s
>= :: Quantity s -> Quantity s -> Bool
$c>= :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
> :: Quantity s -> Quantity s -> Bool
$c> :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
<= :: Quantity s -> Quantity s -> Bool
$c<= :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
< :: Quantity s -> Quantity s -> Bool
$c< :: forall (s :: Nat). Quantity s -> Quantity s -> Bool
compare :: Quantity s -> Quantity s -> Ordering
$ccompare :: forall (s :: Nat). Quantity s -> Quantity s -> Ordering
$cp1Ord :: forall (s :: Nat). Eq (Quantity s)
Ord, (forall x. Quantity s -> Rep (Quantity s) x)
-> (forall x. Rep (Quantity s) x -> Quantity s)
-> Generic (Quantity s)
forall x. Rep (Quantity s) x -> Quantity s
forall x. Quantity s -> Rep (Quantity s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: Nat) x. Rep (Quantity s) x -> Quantity s
forall (s :: Nat) x. Quantity s -> Rep (Quantity s) x
$cto :: forall (s :: Nat) x. Rep (Quantity s) x -> Quantity s
$cfrom :: forall (s :: Nat) x. Quantity s -> Rep (Quantity s) x
Generic, Integer -> Quantity s
Quantity s -> Quantity s
Quantity s -> Quantity s -> Quantity s
(Quantity s -> Quantity s -> Quantity s)
-> (Quantity s -> Quantity s -> Quantity s)
-> (Quantity s -> Quantity s -> Quantity s)
-> (Quantity s -> Quantity s)
-> (Quantity s -> Quantity s)
-> (Quantity s -> Quantity s)
-> (Integer -> Quantity s)
-> Num (Quantity s)
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
forall (s :: Nat). KnownNat s => Integer -> Quantity s
forall (s :: Nat). KnownNat s => Quantity s -> Quantity s
forall (s :: Nat).
KnownNat s =>
Quantity s -> Quantity s -> Quantity s
fromInteger :: Integer -> Quantity s
$cfromInteger :: forall (s :: Nat). KnownNat s => Integer -> Quantity s
signum :: Quantity s -> Quantity s
$csignum :: forall (s :: Nat). KnownNat s => Quantity s -> Quantity s
abs :: Quantity s -> Quantity s
$cabs :: forall (s :: Nat). KnownNat s => Quantity s -> Quantity s
negate :: Quantity s -> Quantity s
$cnegate :: forall (s :: Nat). KnownNat s => Quantity s -> Quantity s
* :: Quantity s -> Quantity s -> Quantity s
$c* :: forall (s :: Nat).
KnownNat s =>
Quantity s -> Quantity s -> Quantity s
- :: Quantity s -> Quantity s -> Quantity s
$c- :: forall (s :: Nat).
KnownNat s =>
Quantity s -> Quantity s -> Quantity s
+ :: Quantity s -> Quantity s -> Quantity s
$c+ :: forall (s :: Nat).
KnownNat s =>
Quantity s -> Quantity s -> Quantity s
Num)


-- | Orphan 'TH.Lift' instance for 'Quantity'.
--
-- TODO: Avoid having an orphan instance for @Decimal r s p@?
deriving instance TH.Lift (D.Decimal D.RoundHalfEven s Integer)


-- | 'TH.Lift' instance for 'Quantity'.
deriving instance TH.Lift (Quantity s)


-- | 'Aeson.FromJSON' instance for 'Quantity'.
--
-- >>> Aeson.decode "0.42" :: Maybe (Quantity 2)
-- Just 0.42
-- >>> Aeson.decode "0.415" :: Maybe (Quantity 2)
-- Just 0.42
-- >>> Aeson.decode "0.425" :: Maybe (Quantity 2)
-- Just 0.42
instance (KnownNat s) => Aeson.FromJSON (Quantity s) where
  parseJSON :: Value -> Parser (Quantity s)
parseJSON = String
-> (Scientific -> Parser (Quantity s))
-> Value
-> Parser (Quantity s)
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
Aeson.withScientific String
"Quantity" (Quantity s -> Parser (Quantity s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantity s -> Parser (Quantity s))
-> (Scientific -> Quantity s) -> Scientific -> Parser (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Quantity s
forall (s :: Nat). KnownNat s => Scientific -> Quantity s
quantity)


-- | 'Aeson.ToJSON' instance for 'Quantity'.
--
-- >>> Aeson.encode (quantity 0.42 :: Quantity 2)
-- "0.42"
instance (KnownNat s) => Aeson.ToJSON (Quantity s) where
  toJSON :: Quantity s -> Value
toJSON = Scientific -> Value
Aeson.Number (Scientific -> Value)
-> (Quantity s -> Scientific) -> Quantity s -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decimal RoundHalfEven s Integer -> Scientific
forall p (s :: Nat) r.
(Integral p, KnownNat s) =>
Decimal r s p -> Scientific
D.toScientificDecimal (Decimal RoundHalfEven s Integer -> Scientific)
-> (Quantity s -> Decimal RoundHalfEven s Integer)
-> Quantity s
-> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity s -> Decimal RoundHalfEven s Integer
forall (s :: Nat). Quantity s -> Decimal RoundHalfEven s Integer
unQuantity


-- | Numeric arithmetic over 'Quantity' values.
--
-- >>> import Numeric.Decimal
-- >>> let a = Arith (quantity 10) + Arith (quantity 32) :: Arith (Quantity 2)
-- >>> arithMaybe a
-- Just 42.00
-- >>> arithM (41 + 1) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (43 - 1) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (2 * 3 * 7) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (signum 42) :: Either SomeException (Quantity 2)
-- Right 1.00
-- >>> arithM (signum (-42)) :: Either SomeException (Quantity 2)
-- Right -1.00
-- >>> arithM (abs 42) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (abs (-42)) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (fromInteger 42) :: Either SomeException (Quantity 2)
-- Right 42.00
instance (KnownNat s) => Num (D.Arith (Quantity s)) where
  + :: Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
(+) = (Quantity s -> Quantity s -> Quantity s)
-> Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Quantity s -> Quantity s -> Quantity s
forall a. Num a => a -> a -> a
(+)
  (-) = (Quantity s -> Quantity s -> Quantity s)
-> Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-)
  * :: Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
(*) = (Quantity s -> Quantity s -> Quantity s)
-> Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Quantity s -> Quantity s -> Quantity s
forall a. Num a => a -> a -> a
(*)
  signum :: Arith (Quantity s) -> Arith (Quantity s)
signum = (Quantity s -> Quantity s)
-> Arith (Quantity s) -> Arith (Quantity s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Quantity s -> Quantity s
forall a. Num a => a -> a
signum
  abs :: Arith (Quantity s) -> Arith (Quantity s)
abs = (Quantity s -> Quantity s)
-> Arith (Quantity s) -> Arith (Quantity s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Quantity s -> Quantity s
forall a. Num a => a -> a
abs
  fromInteger :: Integer -> Arith (Quantity s)
fromInteger = Quantity s -> Arith (Quantity s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantity s -> Arith (Quantity s))
-> (Integer -> Quantity s) -> Integer -> Arith (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decimal RoundHalfEven s Integer -> Quantity s
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity (Decimal RoundHalfEven s Integer -> Quantity s)
-> (Integer -> Decimal RoundHalfEven s Integer)
-> Integer
-> Quantity s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Decimal RoundHalfEven s Integer
forall r (s :: Nat). KnownNat s => Integer -> Decimal r s Integer
D.fromIntegerDecimal


-- | Fractional arithmetic over 'Quantity' values.
--
-- >>> import Numeric.Decimal
-- >>> arithM (fromRational 0.42) :: Either SomeException (Quantity 2)
-- Right 0.42
-- >>> arithM (fromRational 0.415) :: Either SomeException (Quantity 2)
-- Left PrecisionLoss (83 % 200) to 2 decimal spaces
-- >>> arithM $ (fromRational 0.84) / (fromRational 2) :: Either SomeException (Quantity 2)
-- Right 0.42
-- >>> arithM $ (fromRational 0.42) / (fromRational 0) :: Either SomeException (Quantity 2)
-- Left divide by zero
-- >>> let a = 84 :: Quantity 2
-- >>> let b =  2 :: Quantity 2
-- >>> let c =  0 :: Quantity 2
-- >>> arithM (Arith a / Arith b) :: Either SomeException (Quantity 2)
-- Right 42.00
-- >>> arithM (Arith a / Arith b / Arith c) :: Either SomeException (Quantity 2)
-- Left divide by zero
instance (KnownNat s) => Fractional (D.Arith (Quantity s)) where
  Arith (Quantity s)
a / :: Arith (Quantity s) -> Arith (Quantity s) -> Arith (Quantity s)
/ Arith (Quantity s)
b = (Decimal RoundHalfEven s Integer -> Quantity s)
-> Arith (Decimal RoundHalfEven s Integer) -> Arith (Quantity s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Decimal RoundHalfEven s Integer -> Quantity s
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity (Arith (Decimal RoundHalfEven s Integer) -> Arith (Quantity s))
-> Arith (Decimal RoundHalfEven s Integer) -> Arith (Quantity s)
forall a b. (a -> b) -> a -> b
$ (Quantity s -> Decimal RoundHalfEven s Integer)
-> Arith (Quantity s) -> Arith (Decimal RoundHalfEven s Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Quantity s -> Decimal RoundHalfEven s Integer
forall (s :: Nat). Quantity s -> Decimal RoundHalfEven s Integer
unQuantity Arith (Quantity s)
a Arith (Decimal RoundHalfEven s Integer)
-> Arith (Decimal RoundHalfEven s Integer)
-> Arith (Decimal RoundHalfEven s Integer)
forall a. Fractional a => a -> a -> a
/ (Quantity s -> Decimal RoundHalfEven s Integer)
-> Arith (Quantity s) -> Arith (Decimal RoundHalfEven s Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Quantity s -> Decimal RoundHalfEven s Integer
forall (s :: Nat). Quantity s -> Decimal RoundHalfEven s Integer
unQuantity Arith (Quantity s)
b
  fromRational :: Rational -> Arith (Quantity s)
fromRational = (Decimal RoundHalfEven s Integer -> Quantity s)
-> Arith (Decimal RoundHalfEven s Integer) -> Arith (Quantity s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Decimal RoundHalfEven s Integer -> Quantity s
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity (Arith (Decimal RoundHalfEven s Integer) -> Arith (Quantity s))
-> (Rational -> Arith (Decimal RoundHalfEven s Integer))
-> Rational
-> Arith (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Arith (Decimal RoundHalfEven s Integer)
forall (m :: * -> *) r (s :: Nat).
(MonadThrow m, KnownNat s) =>
Rational -> m (Decimal r s Integer)
D.fromRationalDecimalWithoutLoss


-- | 'Show' instance for 'Quantity'.
--
-- >>> show (42 :: Quantity 2)
-- "42.00"
-- >>> 42 :: Quantity 2
-- 42.00
instance KnownNat s => Show (Quantity s) where
  show :: Quantity s -> String
show = Decimal RoundHalfEven s Integer -> String
forall a. Show a => a -> String
show (Decimal RoundHalfEven s Integer -> String)
-> (Quantity s -> Decimal RoundHalfEven s Integer)
-> Quantity s
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quantity s -> Decimal RoundHalfEven s Integer
forall (s :: Nat). Quantity s -> Decimal RoundHalfEven s Integer
unQuantity


-- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way.
--
-- This function uses 'quantityAux' in case that the lossless attempt fails. We
-- could have used 'quantityAux' directly. However, 'quantityAux' is doing too
-- much (see 'roundScientific'). Therefore, we are first attempting a lossless
-- construction (see 'quantityLossless') and we fallback to 'quantityAux' in
-- case the lossless construction fails.
--
-- >>> quantity 0 :: Quantity 0
-- 0
-- >>> quantity 0 :: Quantity 1
-- 0.0
-- >>> quantity 0 :: Quantity 2
-- 0.00
-- >>> quantity 0.04 :: Quantity 1
-- 0.0
-- >>> quantity 0.05 :: Quantity 1
-- 0.0
-- >>> quantity 0.06 :: Quantity 1
-- 0.1
-- >>> quantity 0.14 :: Quantity 1
-- 0.1
-- >>> quantity 0.15 :: Quantity 1
-- 0.2
-- >>> quantity 0.16 :: Quantity 1
-- 0.2
-- >>> quantity 0.04 :: Quantity 2
-- 0.04
-- >>> quantity 0.05 :: Quantity 2
-- 0.05
-- >>> quantity 0.06 :: Quantity 2
-- 0.06
-- >>> quantity 0.14 :: Quantity 2
-- 0.14
-- >>> quantity 0.15 :: Quantity 2
-- 0.15
-- >>> quantity 0.16 :: Quantity 2
-- 0.16
-- >>> quantity 0.04 :: Quantity 3
-- 0.040
-- >>> quantity 0.05 :: Quantity 3
-- 0.050
-- >>> quantity 0.06 :: Quantity 3
-- 0.060
-- >>> quantity 0.14 :: Quantity 3
-- 0.140
-- >>> quantity 0.15 :: Quantity 3
-- 0.150
-- >>> quantity 0.16 :: Quantity 3
-- 0.160
quantity :: KnownNat s => S.Scientific -> Quantity s
quantity :: Scientific -> Quantity s
quantity Scientific
s = case Scientific -> Either String (Quantity s)
forall (s :: Nat) (m :: * -> *).
(KnownNat s, MonadError String m) =>
Scientific -> m (Quantity s)
quantityLossless Scientific
s of
  Left String
_   -> Scientific -> Quantity s
forall (s :: Nat). KnownNat s => Scientific -> Quantity s
quantityAux Scientific
s
  Right Quantity s
dv -> Quantity s
dv


-- | Auxiliary function for 'quantity' implementation.
--
-- See 'quantity' why we need this function and why we haven't used it as the
-- direct implementation of 'quantity'.
--
-- Call-sites should avoid using this function directly due to its performance
-- characteristics.
quantityAux :: forall s. KnownNat s => S.Scientific -> Quantity s
quantityAux :: Scientific -> Quantity s
quantityAux Scientific
x = Quantity s -> Either String (Quantity s) -> Quantity s
forall b a. b -> Either a b -> b
fromRight Quantity s
forall a. a
err (Either String (Quantity s) -> Quantity s)
-> Either String (Quantity s) -> Quantity s
forall a b. (a -> b) -> a -> b
$ Scientific -> Either String (Quantity s)
forall (s :: Nat) (m :: * -> *).
(KnownNat s, MonadError String m) =>
Scientific -> m (Quantity s)
quantityLossless (Int -> Scientific -> Scientific
roundScientific Int
nof Scientific
x)
  where
    -- Get the term-level scaling for the target value:
    nof :: Int
nof = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy s -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s)

    -- This function should NOT fail in practice ever, but theoretically it can
    -- due to type signatures. We will let it error with a message to ourselves:
    err :: a
err = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"PROGRAMMING ERROR: Can not construct 'Quantity " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
nof String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' with '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Scientific -> String
forall a. Show a => a -> String
show Scientific
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"' in a lossy way."


-- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way.
--
-- >>> quantityLossless 0 :: Either String (Quantity 0)
-- Right 0
-- >>> quantityLossless 0 :: Either String (Quantity 1)
-- Right 0.0
-- >>> quantityLossless 0 :: Either String (Quantity 2)
-- Right 0.00
-- >>> quantityLossless 0.04 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 4.0e-2"
-- >>> quantityLossless 0.05 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 5.0e-2"
-- >>> quantityLossless 0.06 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 6.0e-2"
-- >>> quantityLossless 0.14 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.14"
-- >>> quantityLossless 0.15 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.15"
-- >>> quantityLossless 0.16 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.16"
-- >>> quantityLossless 0.04 :: Either String (Quantity 2)
-- Right 0.04
-- >>> quantityLossless 0.05 :: Either String (Quantity 2)
-- Right 0.05
-- >>> quantityLossless 0.06 :: Either String (Quantity 2)
-- Right 0.06
-- >>> quantityLossless 0.14 :: Either String (Quantity 2)
-- Right 0.14
-- >>> quantityLossless 0.15 :: Either String (Quantity 2)
-- Right 0.15
-- >>> quantityLossless 0.16 :: Either String (Quantity 2)
-- Right 0.16
-- >>> quantityLossless 0.04 :: Either String (Quantity 3)
-- Right 0.040
-- >>> quantityLossless 0.05 :: Either String (Quantity 3)
-- Right 0.050
-- >>> quantityLossless 0.06 :: Either String (Quantity 3)
-- Right 0.060
-- >>> quantityLossless 0.14 :: Either String (Quantity 3)
-- Right 0.140
-- >>> quantityLossless 0.15 :: Either String (Quantity 3)
-- Right 0.150
-- >>> quantityLossless 0.16 :: Either String (Quantity 3)
-- Right 0.160
quantityLossless :: (KnownNat s, MonadError String m) => S.Scientific -> m (Quantity s)
quantityLossless :: Scientific -> m (Quantity s)
quantityLossless Scientific
s = (SomeException -> m (Quantity s))
-> (Decimal RoundHalfEven s Integer -> m (Quantity s))
-> Either SomeException (Decimal RoundHalfEven s Integer)
-> m (Quantity s)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Quantity s) -> SomeException -> m (Quantity s)
forall a b. a -> b -> a
const (m (Quantity s) -> SomeException -> m (Quantity s))
-> m (Quantity s) -> SomeException -> m (Quantity s)
forall a b. (a -> b) -> a -> b
$ String -> m (Quantity s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"Underflow while trying to create quantity: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Scientific -> String
forall a. Show a => a -> String
show Scientific
s)) (Quantity s -> m (Quantity s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantity s -> m (Quantity s))
-> (Decimal RoundHalfEven s Integer -> Quantity s)
-> Decimal RoundHalfEven s Integer
-> m (Quantity s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decimal RoundHalfEven s Integer -> Quantity s
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity) (Either SomeException (Decimal RoundHalfEven s Integer)
 -> m (Quantity s))
-> Either SomeException (Decimal RoundHalfEven s Integer)
-> m (Quantity s)
forall a b. (a -> b) -> a -> b
$ Scientific
-> Either SomeException (Decimal RoundHalfEven s Integer)
forall (m :: * -> *) r (s :: Nat).
(MonadThrow m, KnownNat s) =>
Scientific -> m (Decimal r s Integer)
D.fromScientificDecimal Scientific
s


-- | Rounds given quantity by @k@ digits.
--
-- >>> roundQuantity (quantity 0.415 :: Quantity 3) :: Quantity 2
-- 0.42
-- >>> roundQuantity (quantity 0.425 :: Quantity 3) :: Quantity 2
-- 0.42
roundQuantity :: KnownNat k => Quantity (n + k) -> Quantity n
roundQuantity :: Quantity (n + k) -> Quantity n
roundQuantity (MkQuantity Decimal RoundHalfEven (n + k) Integer
d) = Decimal RoundHalfEven n Integer -> Quantity n
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity (Decimal RoundHalfEven (n + k) Integer
-> Decimal RoundHalfEven n Integer
forall r p (k :: Nat) (n :: Nat).
(Round r p, KnownNat k) =>
Decimal r (n + k) p -> Decimal r n p
D.roundDecimal Decimal RoundHalfEven (n + k) Integer
d)


-- | Multiplies two quantities with different scales and rounds back to the scale of the frst operand.
--
-- >>> times (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2)
-- 0.18
times :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity s
times :: Quantity s -> Quantity k -> Quantity s
times Quantity s
q1 Quantity k
q2 = Quantity (s + k) -> Quantity s
forall (k :: Nat) (n :: Nat).
KnownNat k =>
Quantity (n + k) -> Quantity n
roundQuantity (Quantity s -> Quantity k -> Quantity (s + k)
forall (s :: Nat) (k :: Nat).
(KnownNat s, KnownNat k) =>
Quantity s -> Quantity k -> Quantity (s + k)
timesLossless Quantity s
q1 Quantity k
q2)


-- | Multiplies two quantities with different scales.
--
-- >>> timesLossless (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2)
-- 0.1764
timesLossless :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity (s + k)
timesLossless :: Quantity s -> Quantity k -> Quantity (s + k)
timesLossless (MkQuantity Decimal RoundHalfEven s Integer
d1) (MkQuantity Decimal RoundHalfEven k Integer
d2) = Decimal RoundHalfEven (s + k) Integer -> Quantity (s + k)
forall (s :: Nat). Decimal RoundHalfEven s Integer -> Quantity s
MkQuantity (Decimal RoundHalfEven s Integer
-> Decimal RoundHalfEven k Integer
-> Decimal RoundHalfEven (s + k) Integer
forall r (s1 :: Nat) (s2 :: Nat).
Decimal r s1 Integer
-> Decimal r s2 Integer -> Decimal r (s1 + s2) Integer
D.timesDecimal Decimal RoundHalfEven s Integer
d1 Decimal RoundHalfEven k Integer
d2)


-- | Rounds a given scientific into a new scientific with given max digits after
-- decimal point.
--
-- This uses half-even rounding method.
--
-- >>> roundScientific 0 0.4
-- 0.0
-- >>> roundScientific 0 0.5
-- 0.0
-- >>> roundScientific 0 0.6
-- 1.0
-- >>> roundScientific 0 1.4
-- 1.0
-- >>> roundScientific 0 1.5
-- 2.0
-- >>> roundScientific 0 1.6
-- 2.0
-- >>> roundScientific 1 0.04
-- 0.0
-- >>> roundScientific 1 0.05
-- 0.0
-- >>> roundScientific 1 0.06
-- 0.1
-- >>> roundScientific 1 0.14
-- 0.1
-- >>> roundScientific 1 0.15
-- 0.2
-- >>> roundScientific 1 0.16
-- 0.2
-- >>> roundScientific 1 3.650
-- 3.6
-- >>> roundScientific 1 3.740
-- 3.7
-- >>> roundScientific 1 3.749
-- 3.7
-- >>> roundScientific 1 3.750
-- 3.8
-- >>> roundScientific 1 3.751
-- 3.8
-- >>> roundScientific 1  3.760
-- 3.8
-- >>> roundScientific 1 (-3.650)
-- -3.6
-- >>> roundScientific 1 (-3.740)
-- -3.7
-- >>> roundScientific 1 (-3.749)
-- -3.7
-- >>> roundScientific 1 (-3.750)
-- -3.8
-- >>> roundScientific 1 (-3.751)
-- -3.8
-- >>> roundScientific 1 (-3.760)
-- -3.8
--
-- TODO: Refactor to improve the performance of this function.
roundScientific :: Int -> S.Scientific -> S.Scientific
roundScientific :: Int -> Scientific -> Scientific
roundScientific = (String -> Scientific
forall a. Read a => String -> a
read (String -> Scientific)
-> (Scientific -> String) -> Scientific -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Scientific -> String) -> Scientific -> Scientific)
-> (Int -> Scientific -> String) -> Int -> Scientific -> Scientific
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FPFormat -> Maybe Int -> Scientific -> String
S.formatScientific FPFormat
S.Fixed (Maybe Int -> Scientific -> String)
-> (Int -> Maybe Int) -> Int -> Scientific -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just