{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Money.Store () where
import Control.Monad (when)
import Data.Ratio ((%), numerator, denominator)
import GHC.TypeLits (KnownSymbol)
import qualified Data.Store as Store
import qualified Money
import qualified Money.Internal as MoneyI
instance (KnownSymbol currency) => Store.Store (Money.Dense currency) where
size = storeContramapSize Money.toSomeDense Store.size
poke = Store.poke . Money.toSomeDense
peek = maybe (fail "peek") pure =<< fmap Money.fromSomeDense Store.peek
instance Store.Store Money.SomeDense where
poke = \sd -> do
Store.poke (MoneyI.someDenseCurrency' sd)
let r = Money.someDenseAmount sd
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 (MoneyI.mkSomeDense' c (n % d))
instance
( KnownSymbol currency, Money.GoodScale scale
) => Store.Store (Money.Discrete' currency scale) where
size = storeContramapSize Money.toSomeDiscrete Store.size
poke = Store.poke . Money.toSomeDiscrete
peek = maybe (fail "peek") pure =<< fmap Money.fromSomeDiscrete Store.peek
instance Store.Store Money.Scale where
poke = \s -> do
let r = Money.scaleToRational s
Store.poke (numerator r)
Store.poke (denominator r)
peek = maybe (fail "peek") pure =<< do
n :: Integer <- Store.peek
d :: Integer <- Store.peek
when (d == 0) (fail "denominator is zero")
pure (Money.scaleFromRational (n % d))
instance Store.Store Money.SomeDiscrete where
poke = \sd -> do
Store.poke (MoneyI.someDiscreteCurrency' sd)
Store.poke (Money.someDiscreteScale sd)
Store.poke (Money.someDiscreteAmount sd)
peek = do
c :: String <- Store.peek
s :: Money.Scale <- Store.peek
a :: Integer <- Store.peek
pure (MoneyI.mkSomeDiscrete' c s a)
instance
( KnownSymbol src, KnownSymbol dst
) => Store.Store (Money.ExchangeRate src dst) where
size = storeContramapSize Money.toSomeExchangeRate Store.size
poke = Store.poke . Money.toSomeExchangeRate
peek = maybe (fail "peek") pure =<< fmap Money.fromSomeExchangeRate Store.peek
instance Store.Store Money.SomeExchangeRate where
poke = \ser -> do
Store.poke (MoneyI.someExchangeRateSrcCurrency' ser)
Store.poke (MoneyI.someExchangeRateDstCurrency' ser)
let r = Money.someExchangeRateRate ser
Store.poke (numerator r)
Store.poke (denominator r)
peek = maybe (fail "peek") pure =<< do
src :: String <- Store.peek
dst :: String <- Store.peek
n :: Integer <- Store.peek
d :: Integer <- Store.peek
when (d == 0) (fail "denominator is zero")
pure (MoneyI.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
{-# INLINABLE storeContramapSize #-}