#if MIN_VERSION_base(4,9,0)
#endif
module Money.Internal
(
Dense
, dense
, Discrete
, Discrete'
, fromDiscrete
, round
, ceiling
, floor
, truncate
, Scale
, GoodScale
, ErrScaleNonCanonical
, scale
, ExchangeRate
, exchangeRate
, fromExchangeRate
, flipExchangeRate
, exchange
, SomeDense
, toSomeDense
, mkSomeDense
, fromSomeDense
, withSomeDense
, someDenseCurrency
, someDenseAmount
, SomeDiscrete
, toSomeDiscrete
, mkSomeDiscrete
, fromSomeDiscrete
, withSomeDiscrete
, someDiscreteCurrency
, someDiscreteScale
, someDiscreteAmount
, SomeExchangeRate
, toSomeExchangeRate
, mkSomeExchangeRate
, fromSomeExchangeRate
, withSomeExchangeRate
, someExchangeRateSrcCurrency
, someExchangeRateDstCurrency
, someExchangeRateRate
) where
import Control.Applicative ((<|>), empty)
import Control.Category (Category((.), id))
import Control.Monad ((<=<), guard, when)
import Data.Constraint (Dict(Dict))
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Data.Ratio ((%), numerator, denominator)
import GHC.Exts (fromList)
import qualified GHC.Generics as GHC
import GHC.Real (infinity, notANumber)
import GHC.TypeLits
(Symbol, SomeSymbol(..), Nat, SomeNat(..), CmpNat, KnownSymbol, KnownNat,
natVal, someNatVal, symbolVal, someSymbolVal)
import Prelude hiding ((.), round, ceiling, floor, truncate)
import qualified Prelude
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.Read as Read
import Unsafe.Coerce (unsafeCoerce)
#ifdef HAS_aeson
import qualified Data.Aeson as Ae
#endif
#ifdef HAS_binary
import qualified Data.Binary as Binary
#endif
#ifdef HAS_cereal
import qualified Data.Serialize as Cereal
#endif
#ifdef HAS_deepseq
import Control.DeepSeq (NFData)
#endif
#ifdef HAS_hashable
import Data.Hashable (Hashable)
#endif
#ifdef HAS_serialise
import qualified Codec.Serialise as Ser
#endif
#ifdef HAS_store
import qualified Data.Store as Store
#endif
#ifdef HAS_xmlbf
import qualified Xmlbf
import qualified Data.Text as Text
#endif
#if MIN_VERSION_base(4,9,0)
import qualified GHC.TypeLits as GHC
#endif
newtype Dense (currency :: Symbol) = Dense Rational
deriving (Eq, Ord, Num, Real, GHC.Generic)
deriving instance Fractional (Dense (currency :: Symbol))
instance forall currency. KnownSymbol currency => Show (Dense currency) where
showsPrec n = \(Dense r0) ->
let c = symbolVal (Proxy :: Proxy currency)
in showParen (n > 10) $
showString "Dense " . showsPrec 0 c . showChar ' ' .
showsPrec 0 (numerator r0) . showChar '%' .
showsPrec 0 (denominator r0)
instance forall currency. KnownSymbol currency => Read (Dense currency) where
readPrec = Read.parens $ do
let c = symbolVal (Proxy :: Proxy currency)
_ <- ReadPrec.lift (ReadP.string ("Dense " ++ show c ++ " "))
maybe empty pure =<< fmap dense Read.readPrec
dense :: Rational -> Maybe (Dense currency)
dense = \r0 -> if (denominator r0 == 0) then Nothing else Just (Dense r0)
type Discrete (currency :: Symbol) (unit :: Symbol)
= Discrete' currency (Scale currency unit)
newtype Discrete' (currency :: Symbol) (scale :: (Nat, Nat))
= Discrete Integer
deriving instance GoodScale scale => Eq (Discrete' currency scale)
deriving instance GoodScale scale => Ord (Discrete' currency scale)
deriving instance GoodScale scale => Enum (Discrete' currency scale)
deriving instance GoodScale scale => Num (Discrete' currency scale)
deriving instance GoodScale scale => Real (Discrete' currency scale)
deriving instance GoodScale scale => Integral (Discrete' currency scale)
deriving instance GoodScale scale => GHC.Generic (Discrete' currency scale)
instance forall currency scale.
( KnownSymbol currency, GoodScale scale
) => Show (Discrete' currency scale) where
showsPrec n = \d0@(Discrete i0) ->
let c = symbolVal (Proxy :: Proxy currency)
s = scale d0
in showParen (n > 10) $
showString "Discrete " . showsPrec 0 c . showChar ' ' .
showsPrec 0 (numerator s) . showChar '%' .
showsPrec 0 (denominator s) . showChar ' ' .
showsPrec 0 i0
instance forall currency scale.
( KnownSymbol currency, GoodScale scale
) => Read (Discrete' currency scale) where
readPrec = Read.parens $ do
let c = symbolVal (Proxy :: Proxy currency)
s = scale (Proxy :: Proxy scale)
_ <- ReadPrec.lift (ReadP.string (concat
[ "Discrete ", show c, " "
, show (numerator s), "%"
, show (denominator s), " "
]))
Discrete <$> Read.readPrec
#if MIN_VERSION_base(4,9,0)
instance
( GHC.TypeError
(('GHC.Text "The ") 'GHC.:<>:
('GHC.ShowType Discrete') 'GHC.:<>:
('GHC.Text " type is deliberately not a ") 'GHC.:<>:
('GHC.ShowType Fractional) 'GHC.:$$:
('GHC.Text "instance. Convert the ") 'GHC.:<>:
('GHC.ShowType Discrete') 'GHC.:<>:
('GHC.Text " value to a ") 'GHC.:<>:
('GHC.ShowType Dense) 'GHC.:$$:
('GHC.Text "value and use the ") 'GHC.:<>:
('GHC.ShowType Fractional) 'GHC.:<>:
('GHC.Text " features on it instead."))
, GoodScale scale
) => Fractional (Discrete' currency scale) where
fromRational = undefined
recip = undefined
#endif
fromDiscrete
:: GoodScale scale
=> Discrete' currency scale
-> Dense currency
fromDiscrete = \c@(Discrete i) -> Dense (fromInteger i / scale c)
roundf
:: forall currency scale
. GoodScale scale
=> (Rational -> Integer)
-> Dense currency
-> (Discrete' currency scale, Dense currency)
roundf f = \c0 ->
let !r0 = toRational c0 :: Rational
!r1 = scale (Proxy :: Proxy scale)
!i2 = f (r0 * r1) :: Integer
!r2 = fromInteger i2 / r1 :: Rational
!d2 = Discrete i2
!rest = Dense (r0 r2)
in (d2, rest)
round
:: GoodScale scale
=> Dense currency
-> (Discrete' currency scale, Dense currency)
round = roundf Prelude.round
ceiling
:: GoodScale scale
=> Dense currency
-> (Discrete' currency scale, Dense currency)
ceiling = roundf Prelude.ceiling
floor
:: GoodScale scale
=> Dense currency
-> (Discrete' currency scale, Dense currency)
floor = roundf Prelude.floor
truncate
:: GoodScale scale
=> Dense currency
-> (Discrete' currency scale, Dense currency)
truncate = roundf Prelude.truncate
type family Scale (currency :: Symbol) (unit :: Symbol) :: (Nat, Nat)
#if MIN_VERSION_base(4,9,0)
type family ErrScaleNonCanonical (currency :: Symbol) :: k where
ErrScaleNonCanonical c = GHC.TypeError
( 'GHC.Text c 'GHC.:<>:
'GHC.Text " is not a currency with a canonical smallest unit," 'GHC.:$$:
'GHC.Text "be explicit about the currency unit you want to use." )
#else
type ErrScaleNonCanonical (currency :: Symbol) = '(0, 0)
#endif
type GoodScale (scale :: (Nat, Nat))
= ( CmpNat 0 (Fst scale) ~ 'LT
, CmpNat 0 (Snd scale) ~ 'LT
, KnownNat (Fst scale)
, KnownNat (Snd scale)
)
mkGoodScale
:: forall num den
. (KnownNat num, KnownNat den)
=> Maybe (Dict (GoodScale '(num, den)))
mkGoodScale =
let n = natVal (Proxy :: Proxy num)
d = natVal (Proxy :: Proxy den)
in if (n > 0) && (d > 0)
then Just (unsafeCoerce (Dict :: Dict ('LT ~ 'LT, 'LT ~ 'LT,
KnownNat num, KnownNat den)))
else Nothing
scale :: forall proxy scale. GoodScale scale => proxy scale -> Rational
scale = \_ ->
natVal (Proxy :: Proxy (Fst scale)) %
natVal (Proxy :: Proxy (Snd scale))
newtype ExchangeRate (src :: Symbol) (dst :: Symbol) = ExchangeRate Rational
deriving (Eq, Ord, GHC.Generic)
instance Category ExchangeRate where
id = ExchangeRate 1
ExchangeRate a . ExchangeRate b = ExchangeRate (a * b)
instance forall src dst.
( KnownSymbol src, KnownSymbol dst
) => Show (ExchangeRate src dst) where
showsPrec n = \(ExchangeRate r0) ->
let s = symbolVal (Proxy :: Proxy src)
d = symbolVal (Proxy :: Proxy dst)
in showParen (n > 10) $
showString "ExchangeRate " . showsPrec 0 s . showChar ' ' .
showsPrec 0 d . showChar ' ' .
showsPrec 0 (numerator r0) . showChar '%' .
showsPrec 0 (denominator r0)
instance forall src dst.
( KnownSymbol src, KnownSymbol dst
) => Read (ExchangeRate (src :: Symbol) (dst :: Symbol)) where
readPrec = Read.parens $ do
let s = symbolVal (Proxy :: Proxy src)
d = symbolVal (Proxy :: Proxy dst)
_ <- ReadPrec.lift (ReadP.string
("ExchangeRate " ++ show s ++ " " ++ show d ++ " "))
maybe empty pure =<< fmap exchangeRate Read.readPrec
fromExchangeRate :: ExchangeRate src dst -> Rational
fromExchangeRate = \(ExchangeRate r0) -> r0
exchangeRate :: Rational -> Maybe (ExchangeRate src dst)
exchangeRate = \r0 ->
if (r0 <= 0 || infinity == r0 || notANumber == r0)
then Nothing else Just (ExchangeRate r0)
flipExchangeRate :: ExchangeRate a b -> ExchangeRate b a
flipExchangeRate = \(ExchangeRate x) -> ExchangeRate (1 / x)
exchange :: ExchangeRate src dst -> Dense src -> Dense dst
exchange = \(ExchangeRate r) -> \(Dense s) -> Dense (r * s)
data SomeDense = SomeDense
{ _someDenseCurrency :: !String
, _someDenseAmount :: !Rational
} deriving (Eq, Show, GHC.Generic)
deriving instance Ord SomeDense
someDenseCurrency :: SomeDense -> String
someDenseCurrency = _someDenseCurrency
someDenseAmount :: SomeDense -> Rational
someDenseAmount = _someDenseAmount
mkSomeDense
:: String
-> Rational
-> Maybe SomeDense
mkSomeDense = \c r -> do
guard (denominator r /= 0)
Just (SomeDense c r)
toSomeDense :: KnownSymbol currency => Dense currency -> SomeDense
toSomeDense = \(Dense r0 :: Dense currency) ->
let c = symbolVal (Proxy :: Proxy currency)
in SomeDense c r0
fromSomeDense
:: forall currency
. KnownSymbol currency
=> SomeDense
-> Maybe (Dense currency)
fromSomeDense = \dr -> do
guard (someDenseCurrency dr == symbolVal (Proxy :: Proxy currency))
Just (Dense (someDenseAmount dr))
withSomeDense
:: SomeDense
-> (forall currency. KnownSymbol currency => Dense currency -> r)
-> r
withSomeDense dr = \f ->
case someSymbolVal (someDenseCurrency dr) of
SomeSymbol (Proxy :: Proxy currency) ->
f (Dense (someDenseAmount dr) :: Dense currency)
data SomeDiscrete = SomeDiscrete
{ _someDiscreteCurrency :: !String
, _someDiscreteScale :: !Rational
, _someDiscreteAmount :: !Integer
} deriving (Eq, Show, GHC.Generic)
deriving instance Ord SomeDiscrete
someDiscreteCurrency :: SomeDiscrete -> String
someDiscreteCurrency = _someDiscreteCurrency
someDiscreteScale :: SomeDiscrete -> Rational
someDiscreteScale = _someDiscreteScale
someDiscreteAmount :: SomeDiscrete -> Integer
someDiscreteAmount = _someDiscreteAmount
mkSomeDiscrete
:: String
-> Rational
-> Integer
-> Maybe SomeDiscrete
mkSomeDiscrete = \c r a -> do
guard (denominator r /= 0)
guard (r > 0)
Just (SomeDiscrete c r a)
toSomeDiscrete
:: (KnownSymbol currency, GoodScale scale)
=> Discrete' currency scale
-> SomeDiscrete
toSomeDiscrete = \(Discrete i0 :: Discrete' currency scale) ->
let c = symbolVal (Proxy :: Proxy currency)
n = natVal (Proxy :: Proxy (Fst scale))
d = natVal (Proxy :: Proxy (Snd scale))
in SomeDiscrete c (n % d) i0
fromSomeDiscrete
:: forall currency scale
. (KnownSymbol currency, GoodScale scale)
=> SomeDiscrete
-> Maybe (Discrete' currency scale)
fromSomeDiscrete = \dr ->
if (someDiscreteCurrency dr == symbolVal (Proxy :: Proxy currency)) &&
(someDiscreteScale dr == scale (Proxy :: Proxy scale))
then Just (Discrete (someDiscreteAmount dr))
else Nothing
withSomeDiscrete
:: forall r
. SomeDiscrete
-> ( forall currency scale.
( KnownSymbol currency
, GoodScale scale
) => Discrete' currency scale
-> r )
-> r
withSomeDiscrete dr = \f ->
case someSymbolVal (someDiscreteCurrency dr) of
SomeSymbol (Proxy :: Proxy currency) ->
case someNatVal (numerator (someDiscreteScale dr)) of
Nothing -> error "withSomeDiscrete: impossible: numerator < 0"
Just (SomeNat (Proxy :: Proxy num)) ->
case someNatVal (denominator (someDiscreteScale dr)) of
Nothing -> error "withSomeDiscrete: impossible: denominator < 0"
Just (SomeNat (Proxy :: Proxy den)) ->
case mkGoodScale of
Nothing -> error "withSomeDiscrete: impossible: mkGoodScale"
Just (Dict :: Dict (GoodScale '(num, den))) ->
f (Discrete (someDiscreteAmount dr)
:: Discrete' currency '(num, den))
data SomeExchangeRate = SomeExchangeRate
{ _someExchangeRateSrcCurrency :: !String
, _someExchangeRateDstCurrency :: !String
, _someExchangeRateRate :: !Rational
} deriving (Eq, Show, GHC.Generic)
deriving instance Ord SomeExchangeRate
someExchangeRateSrcCurrency :: SomeExchangeRate -> String
someExchangeRateSrcCurrency = _someExchangeRateSrcCurrency
someExchangeRateDstCurrency :: SomeExchangeRate -> String
someExchangeRateDstCurrency = _someExchangeRateDstCurrency
someExchangeRateRate :: SomeExchangeRate -> Rational
someExchangeRateRate = _someExchangeRateRate
mkSomeExchangeRate
:: String
-> String
-> Rational
-> Maybe SomeExchangeRate
mkSomeExchangeRate = \src dst r -> do
guard (denominator r /= 0)
guard (r > 0)
Just (SomeExchangeRate src dst r)
toSomeExchangeRate
:: (KnownSymbol src, KnownSymbol dst)
=> ExchangeRate src dst
-> SomeExchangeRate
toSomeExchangeRate = \(ExchangeRate r0 :: ExchangeRate src dst) ->
let src = symbolVal (Proxy :: Proxy src)
dst = symbolVal (Proxy :: Proxy dst)
in SomeExchangeRate src dst r0
fromSomeExchangeRate
:: forall src dst
. (KnownSymbol src, KnownSymbol dst)
=> SomeExchangeRate
-> Maybe (ExchangeRate src dst)
fromSomeExchangeRate = \x ->
if (someExchangeRateSrcCurrency x == symbolVal (Proxy :: Proxy src)) &&
(someExchangeRateDstCurrency x == symbolVal (Proxy :: Proxy dst))
then Just (ExchangeRate (someExchangeRateRate x))
else Nothing
withSomeExchangeRate
:: SomeExchangeRate
-> ( forall src dst.
( KnownSymbol src
, KnownSymbol dst
) => ExchangeRate src dst
-> r )
-> r
withSomeExchangeRate x = \f ->
case someSymbolVal (someExchangeRateSrcCurrency x) of
SomeSymbol (Proxy :: Proxy src) ->
case someSymbolVal (someExchangeRateDstCurrency x) of
SomeSymbol (Proxy :: Proxy dst) ->
f (ExchangeRate (someExchangeRateRate x) :: ExchangeRate src dst)
type family Fst (ab :: (ka, kb)) :: ka where Fst '(a,b) = a
type family Snd (ab :: (ka, kb)) :: ka where Snd '(a,b) = b
#ifdef HAS_hashable
instance Hashable (Dense currency)
instance Hashable SomeDense
instance GoodScale scale => Hashable (Discrete' currency scale)
instance Hashable SomeDiscrete
instance Hashable (ExchangeRate src dst)
instance Hashable SomeExchangeRate
#endif
#ifdef HAS_deepseq
instance NFData (Dense currency)
instance NFData SomeDense
instance GoodScale scale => NFData (Discrete' currency scale)
instance NFData SomeDiscrete
instance NFData (ExchangeRate src dst)
instance NFData SomeExchangeRate
#endif
#ifdef HAS_cereal
instance (KnownSymbol currency) => Cereal.Serialize (Dense currency) where
put = Cereal.put . toSomeDense
get = maybe empty pure =<< fmap fromSomeDense Cereal.get
instance
( KnownSymbol currency, GoodScale scale
) => Cereal.Serialize (Discrete' currency scale) where
put = Cereal.put . toSomeDiscrete
get = maybe empty pure =<< fmap fromSomeDiscrete Cereal.get
instance
( KnownSymbol src, KnownSymbol dst
) => Cereal.Serialize (ExchangeRate src dst) where
put = Cereal.put . toSomeExchangeRate
get = maybe empty pure =<< fmap fromSomeExchangeRate Cereal.get
instance Cereal.Serialize SomeDense where
put = \(SomeDense c r) -> do
Cereal.put c
Cereal.put (numerator r)
Cereal.put (denominator r)
get = maybe empty pure =<< do
c :: String <- Cereal.get
n :: Integer <- Cereal.get
d :: Integer <- Cereal.get
when (d == 0) (fail "denominator is zero")
pure (mkSomeDense c (n % d))
instance Cereal.Serialize SomeDiscrete where
put = \(SomeDiscrete c r a) -> do
Cereal.put c
Cereal.put (numerator r)
Cereal.put (denominator r)
Cereal.put a
get = maybe empty pure =<< do
c :: String <- Cereal.get
n :: Integer <- Cereal.get
d :: Integer <- Cereal.get
when (d == 0) (fail "denominator is zero")
a :: Integer <- Cereal.get
pure (mkSomeDiscrete c (n % d) a)
instance Cereal.Serialize SomeExchangeRate where
put = \(SomeExchangeRate src dst r) -> do
Cereal.put src
Cereal.put dst
Cereal.put (numerator r)
Cereal.put (denominator r)
get = maybe empty pure =<< do
src :: String <- Cereal.get
dst :: String <- Cereal.get
n :: Integer <- Cereal.get
d :: Integer <- Cereal.get
when (d == 0) (fail "denominator is zero")
pure (mkSomeExchangeRate src dst (n % d))
#endif
#ifdef HAS_binary
instance (KnownSymbol currency) => Binary.Binary (Dense currency) where
put = Binary.put . toSomeDense
get = maybe empty pure =<< fmap fromSomeDense Binary.get
instance
( KnownSymbol currency, GoodScale scale
) => Binary.Binary (Discrete' currency scale) where
put = Binary.put . toSomeDiscrete
get = maybe empty pure =<< fmap fromSomeDiscrete Binary.get
instance
( KnownSymbol src, KnownSymbol dst
) => Binary.Binary (ExchangeRate src dst) where
put = Binary.put . toSomeExchangeRate
get = maybe empty pure =<< fmap fromSomeExchangeRate Binary.get
instance Binary.Binary SomeDense where
put = \(SomeDense c r) ->
Binary.put c >> Binary.put (numerator r) >> Binary.put (denominator r)
get = maybe empty pure =<< do
c :: String <- Binary.get
n :: Integer <- Binary.get
d :: Integer <- Binary.get
when (d == 0) (fail "denominator is zero")
pure (mkSomeDense c (n % d))
instance Binary.Binary SomeDiscrete where
put = \(SomeDiscrete c r a) ->
Binary.put c <>
Binary.put (numerator r) <>
Binary.put (denominator r) <>
Binary.put a
get = maybe empty pure =<< do
c :: String <- Binary.get
n :: Integer <- Binary.get
d :: Integer <- Binary.get
when (d == 0) (fail "denominator is zero")
a :: Integer <- Binary.get
pure (mkSomeDiscrete c (n % d) a)
instance Binary.Binary SomeExchangeRate where
put = \(SomeExchangeRate src dst r) -> do
Binary.put src
Binary.put dst
Binary.put (numerator r)
Binary.put (denominator r)
get = maybe empty pure =<< do
src :: String <- Binary.get
dst :: String <- Binary.get
n :: Integer <- Binary.get
d :: Integer <- Binary.get
when (d == 0) (fail "denominator is zero")
pure (mkSomeExchangeRate src dst (n % d))
#endif
#ifdef HAS_serialise
instance (KnownSymbol currency) => Ser.Serialise (Dense currency) where
encode = Ser.encode . toSomeDense
decode = maybe (fail "Dense") pure =<< fmap fromSomeDense Ser.decode
instance
( KnownSymbol currency, GoodScale scale
) => Ser.Serialise (Discrete' currency scale) where
encode = Ser.encode . toSomeDiscrete
decode = maybe (fail "Discrete'") pure =<< fmap fromSomeDiscrete Ser.decode
instance
( KnownSymbol src, KnownSymbol dst
) => Ser.Serialise (ExchangeRate src dst) where
encode = Ser.encode . toSomeExchangeRate
decode = maybe (fail "ExchangeRate") pure
=<< fmap fromSomeExchangeRate Ser.decode
instance Ser.Serialise SomeDense where
encode = \(SomeDense c r) ->
Ser.encode c <> Ser.encode (numerator r) <> Ser.encode (denominator r)
decode = maybe (fail "SomeDense") pure =<< do
c :: String <- Ser.decode
n :: Integer <- Ser.decode
d :: Integer <- Ser.decode
when (d == 0) (fail "denominator is zero")
pure (mkSomeDense c (n % d))
instance Ser.Serialise SomeDiscrete where
encode = \(SomeDiscrete c r a) ->
Ser.encode c <>
Ser.encode (numerator r) <>
Ser.encode (denominator r) <>
Ser.encode a
decode = maybe (fail "SomeDiscrete") pure =<< do
c :: String <- Ser.decode
n :: Integer <- Ser.decode
d :: Integer <- Ser.decode
when (d == 0) (fail "denominator is zero")
a :: Integer <- Ser.decode
pure (mkSomeDiscrete c (n % d) a)
instance Ser.Serialise SomeExchangeRate where
encode = \(SomeExchangeRate src dst r) ->
Ser.encode src <>
Ser.encode dst <>
Ser.encode (numerator r) <>
Ser.encode (denominator r)
decode = maybe (fail "SomeExchangeRate") pure =<< do
src :: String <- Ser.decode
dst :: String <- Ser.decode
n :: Integer <- Ser.decode
d :: Integer <- Ser.decode
when (d == 0) (fail "denominator is zero")
pure (mkSomeExchangeRate src dst (n % d))
#endif
#ifdef HAS_aeson
instance KnownSymbol currency => Ae.ToJSON (Dense currency) where
toJSON = Ae.toJSON . toSomeDense
instance KnownSymbol currency => Ae.FromJSON (Dense currency) where
parseJSON = maybe empty pure <=< fmap fromSomeDense . Ae.parseJSON
instance Ae.ToJSON SomeDense where
toJSON = \(SomeDense c r) ->
Ae.toJSON (c, numerator r, denominator r)
instance Ae.FromJSON SomeDense where
parseJSON = \v -> do
(c, n, d) <- Ae.parseJSON v <|> do
("Dense" :: String, c, n, d) <- Ae.parseJSON v
pure (c, n, d)
when (d == 0) (fail "denominator is zero")
maybe empty pure (mkSomeDense c (n % d))
instance
( KnownSymbol currency, GoodScale scale
) => Ae.ToJSON (Discrete' currency scale) where
toJSON = Ae.toJSON . toSomeDiscrete
instance
( KnownSymbol currency, GoodScale scale
) => Ae.FromJSON (Discrete' currency scale) where
parseJSON = maybe empty pure <=< fmap fromSomeDiscrete . Ae.parseJSON
instance Ae.ToJSON SomeDiscrete where
toJSON = \(SomeDiscrete c r a) ->
Ae.toJSON (c, numerator r, denominator r, a)
instance Ae.FromJSON SomeDiscrete where
parseJSON = \v -> do
(c, n, d, a) <- Ae.parseJSON v <|> do
("Discrete" :: String, c, n, d, a) <- Ae.parseJSON v
pure (c, n, d, a)
when (d == 0) (fail "denominator is zero")
maybe empty pure (mkSomeDiscrete c (n % d) a)
instance
( KnownSymbol src, KnownSymbol dst
) => Ae.ToJSON (ExchangeRate src dst) where
toJSON = Ae.toJSON . toSomeExchangeRate
instance
( KnownSymbol src, KnownSymbol dst
) => Ae.FromJSON (ExchangeRate src dst) where
parseJSON = maybe empty pure <=< fmap fromSomeExchangeRate . Ae.parseJSON
instance Ae.ToJSON SomeExchangeRate where
toJSON = \(SomeExchangeRate src dst r) ->
Ae.toJSON (src, dst, numerator r, denominator r)
instance Ae.FromJSON SomeExchangeRate where
parseJSON = \v -> do
(src, dst, n, d) <- Ae.parseJSON v <|> do
("ExchangeRate" :: String, src, dst, n, d) <- Ae.parseJSON v
pure (src, dst, n, d)
when (d == 0) (fail "denominator is zero")
maybe empty pure (mkSomeExchangeRate src dst (n % d))
#endif
#ifdef HAS_xmlbf
instance KnownSymbol currency => Xmlbf.ToXml (Dense currency) where
toXml = Xmlbf.toXml . toSomeDense
instance KnownSymbol currency => Xmlbf.FromXml (Dense currency) where
fromXml = maybe empty pure =<< fmap fromSomeDense Xmlbf.fromXml
instance Xmlbf.ToXml SomeDense where
toXml = \(SomeDense c r) ->
let as = [ (Text.pack "c", Text.pack c)
, (Text.pack "n", Text.pack (show (numerator r)))
, (Text.pack "d", Text.pack (show (denominator r))) ]
Right e = Xmlbf.element (Text.pack "money-dense") (fromList as) []
in [e]
instance Xmlbf.FromXml SomeDense where
fromXml = Xmlbf.pElement (Text.pack "money-dense") $ do
c <- Text.unpack <$> Xmlbf.pAttr "c"
n <- Xmlbf.pRead =<< Xmlbf.pAttr "n"
d <- Xmlbf.pRead =<< Xmlbf.pAttr "d"
when (d == 0) (fail "denominator is zero")
maybe empty pure (mkSomeDense c (n % d))
instance
( KnownSymbol currency, GoodScale scale
) => Xmlbf.ToXml (Discrete' currency scale) where
toXml = Xmlbf.toXml . toSomeDiscrete
instance
( KnownSymbol currency, GoodScale scale
) => Xmlbf.FromXml (Discrete' currency scale) where
fromXml = maybe empty pure =<< fmap fromSomeDiscrete Xmlbf.fromXml
instance Xmlbf.ToXml SomeDiscrete where
toXml = \(SomeDiscrete c r a) ->
let as = [ (Text.pack "c", Text.pack c)
, (Text.pack "n", Text.pack (show (numerator r)))
, (Text.pack "d", Text.pack (show (denominator r)))
, (Text.pack "a", Text.pack (show a)) ]
Right e = Xmlbf.element (Text.pack "money-discrete") (fromList as) []
in [e]
instance Xmlbf.FromXml SomeDiscrete where
fromXml = Xmlbf.pElement (Text.pack "money-discrete") $ do
c <- Text.unpack <$> Xmlbf.pAttr "c"
n <- Xmlbf.pRead =<< Xmlbf.pAttr "n"
d <- Xmlbf.pRead =<< Xmlbf.pAttr "d"
when (d == 0) (fail "denominator is zero")
a <- Xmlbf.pRead =<< Xmlbf.pAttr "a"
maybe empty pure (mkSomeDiscrete c (n % d) a)
instance
( KnownSymbol src, KnownSymbol dst
) => Xmlbf.ToXml (ExchangeRate src dst) where
toXml = Xmlbf.toXml . toSomeExchangeRate
instance
( KnownSymbol src, KnownSymbol dst
) => Xmlbf.FromXml (ExchangeRate src dst) where
fromXml = maybe empty pure =<< fmap fromSomeExchangeRate Xmlbf.fromXml
instance Xmlbf.ToXml SomeExchangeRate where
toXml = \(SomeExchangeRate src dst r) ->
let as = [ (Text.pack "src", Text.pack src)
, (Text.pack "dst", Text.pack dst)
, (Text.pack "n", Text.pack (show (numerator r)))
, (Text.pack "d", Text.pack (show (denominator r))) ]
Right e = Xmlbf.element (Text.pack "exchange-rate") (fromList as) []
in [e]
instance Xmlbf.FromXml SomeExchangeRate where
fromXml = Xmlbf.pElement (Text.pack "exchange-rate") $ do
src <- Text.unpack <$> Xmlbf.pAttr "src"
dst <- Text.unpack <$> Xmlbf.pAttr "dst"
n <- Xmlbf.pRead =<< Xmlbf.pAttr "n"
d <- Xmlbf.pRead =<< Xmlbf.pAttr "d"
when (d == 0) (fail "denominator is zero")
maybe empty pure (mkSomeExchangeRate src dst (n % d))
#endif
#ifdef HAS_store
instance (KnownSymbol currency) => Store.Store (Dense currency) where
size = storeContramapSize toSomeDense Store.size
poke = Store.poke . toSomeDense
peek = maybe (fail "peek") pure =<< fmap fromSomeDense Store.peek
instance Store.Store SomeDense where
poke = \(SomeDense c r) -> do
Store.poke c
Store.poke (numerator r)
Store.poke (denominator r)
peek = maybe (fail "peek") pure =<< do
c :: String <- Store.peek
n :: Integer <- Store.peek
d :: Integer <- Store.peek
when (d == 0) (fail "denominator is zero")
pure (mkSomeDense c (n % d))
instance
( KnownSymbol currency, GoodScale scale
) => Store.Store (Discrete' currency scale) where
size = storeContramapSize toSomeDiscrete Store.size
poke = Store.poke . toSomeDiscrete
peek = maybe (fail "peek") pure =<< fmap fromSomeDiscrete Store.peek
instance Store.Store SomeDiscrete where
poke = \(SomeDiscrete c r a) ->do
Store.poke c
Store.poke (numerator r)
Store.poke (denominator r)
Store.poke a
peek = maybe (fail "peek") pure =<< do
c :: String <- Store.peek
n :: Integer <- Store.peek
d :: Integer <- Store.peek
when (d == 0) (fail "denominator is zero")
a :: Integer <- Store.peek
pure (mkSomeDiscrete c (n % d) a)
instance
( KnownSymbol src, KnownSymbol dst
) => Store.Store (ExchangeRate src dst) where
size = storeContramapSize toSomeExchangeRate Store.size
poke = Store.poke . toSomeExchangeRate
peek = maybe (fail "peek") pure =<< fmap fromSomeExchangeRate Store.peek
instance Store.Store SomeExchangeRate where
poke = \(SomeExchangeRate src dst r) -> do
Store.poke src
Store.poke dst
Store.poke (numerator r)
Store.poke (denominator r)
peek = maybe (fail "peek") pure =<< do
src <- Store.peek
dst <- Store.peek
n <- Store.peek
d <- Store.peek
when (d == 0) (fail "denominator is zero")
pure (mkSomeExchangeRate src dst (n % d))
storeContramapSize :: (a -> b) -> Store.Size b -> Store.Size a
storeContramapSize f = \case
Store.VarSize g -> Store.VarSize (g . f)
Store.ConstSize x -> Store.ConstSize x
#endif