-- | This module provides definitions for modeling and working with quantities
-- with fixed decimal points.

{-# LANGUAGE DataKinds #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Haspara.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           Data.Scientific            (FPFormat(Fixed), Scientific, formatScientific)
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
import           Refined                    (NonNegative, Refined)


-- * Data Definition
-- $dataDefinition


-- | Type encoding for quantity values with a 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
-- >>> mkQuantity 0.415 :: Quantity 2
-- 0.42
-- >>> mkQuantity 0.425 :: Quantity 2
-- 0.42
-- >>> mkQuantityLossless 0.42 :: Either String (Quantity 2)
-- Right 0.42
-- >>> mkQuantityLossless 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)


-- | Type definition for unsigned 'Quantity' values.
type UnsignedQuantity s = Refined NonNegative (Quantity s)


-- | 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
mkQuantity)


-- | 'Aeson.ToJSON' instance for 'Quantity'.
--
-- >>> Aeson.encode (mkQuantity 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 (mkQuantity 10) + Arith (mkQuantity 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


-- * Smart Constructors
-- $smartConstructors


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


-- | Constructs 'Quantity' values from 'Scientific' values in a lossy way.
--
-- >>> mkQuantityLossless 0 :: Either String (Quantity 0)
-- Right 0
-- >>> mkQuantityLossless 0 :: Either String (Quantity 1)
-- Right 0.0
-- >>> mkQuantityLossless 0 :: Either String (Quantity 2)
-- Right 0.00
-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 4.0e-2"
-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 5.0e-2"
-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 6.0e-2"
-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.14"
-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.15"
-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 1)
-- Left "Underflow while trying to create quantity: 0.16"
-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 2)
-- Right 0.04
-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 2)
-- Right 0.05
-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 2)
-- Right 0.06
-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 2)
-- Right 0.14
-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 2)
-- Right 0.15
-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 2)
-- Right 0.16
-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 3)
-- Right 0.040
-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 3)
-- Right 0.050
-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 3)
-- Right 0.060
-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 3)
-- Right 0.140
-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 3)
-- Right 0.150
-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 3)
-- Right 0.160
mkQuantityLossless :: (KnownNat s, MonadError String m) => Scientific -> m (Quantity s)
mkQuantityLossless :: Scientific -> m (Quantity s)
mkQuantityLossless 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


-- * Utilities
-- $utilities


-- | Rounds given quantity by @k@ digits.
--
-- >>> roundQuantity (mkQuantity 0.415 :: Quantity 3) :: Quantity 2
-- 0.42
-- >>> roundQuantity (mkQuantity 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 (mkQuantity 0.42 :: Quantity 2) (mkQuantity 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 (mkQuantity 0.42 :: Quantity 2) (mkQuantity 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)


-- * Internal
-- $internal


-- | Auxiliary function for constructing 'Quantity' values.
--
-- See 'mkQuantity' why we need this function and why we haven't used it as the
-- direct implementation of 'mkQuantity'.
--
-- Call-sites should avoid using this function directly due to its performance
-- characteristics.
mkQuantityAux :: forall s. KnownNat s => Scientific -> Quantity s
mkQuantityAux :: Scientific -> Quantity s
mkQuantityAux 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)
mkQuantityLossless (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 it can fail due to
    -- type signatures by right. We will let it error with a message for
    -- 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."


-- | 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 -> Scientific -> 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
formatScientific FPFormat
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