-- | This module provides internal definitions for modeling and working with
-- currencies.
--
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Haspara.Internal.Currency where

import           Control.Monad.Except       (MonadError(throwError))
import qualified Data.Aeson                 as Aeson
import           Data.Hashable              (Hashable)
import           Data.String                (IsString(..))
import qualified Data.Text                  as T
import           Data.Void                  (Void)
import qualified Language.Haskell.TH.Syntax as TH
import qualified Text.Megaparsec            as MP


-- * Data Definition
-- &definition

-- | Type encoding for currencies.
newtype Currency = MkCurrency { Currency -> Text
currencyCode :: T.Text }
  deriving (Currency -> Currency -> Bool
(Currency -> Currency -> Bool)
-> (Currency -> Currency -> Bool) -> Eq Currency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Currency -> Currency -> Bool
$c/= :: Currency -> Currency -> Bool
== :: Currency -> Currency -> Bool
$c== :: Currency -> Currency -> Bool
Eq, Int -> Currency -> Int
Currency -> Int
(Int -> Currency -> Int) -> (Currency -> Int) -> Hashable Currency
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Currency -> Int
$chash :: Currency -> Int
hashWithSalt :: Int -> Currency -> Int
$chashWithSalt :: Int -> Currency -> Int
Hashable, Eq Currency
Eq Currency
-> (Currency -> Currency -> Ordering)
-> (Currency -> Currency -> Bool)
-> (Currency -> Currency -> Bool)
-> (Currency -> Currency -> Bool)
-> (Currency -> Currency -> Bool)
-> (Currency -> Currency -> Currency)
-> (Currency -> Currency -> Currency)
-> Ord Currency
Currency -> Currency -> Bool
Currency -> Currency -> Ordering
Currency -> Currency -> Currency
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
min :: Currency -> Currency -> Currency
$cmin :: Currency -> Currency -> Currency
max :: Currency -> Currency -> Currency
$cmax :: Currency -> Currency -> Currency
>= :: Currency -> Currency -> Bool
$c>= :: Currency -> Currency -> Bool
> :: Currency -> Currency -> Bool
$c> :: Currency -> Currency -> Bool
<= :: Currency -> Currency -> Bool
$c<= :: Currency -> Currency -> Bool
< :: Currency -> Currency -> Bool
$c< :: Currency -> Currency -> Bool
compare :: Currency -> Currency -> Ordering
$ccompare :: Currency -> Currency -> Ordering
$cp1Ord :: Eq Currency
Ord, Currency -> Q Exp
Currency -> Q (TExp Currency)
(Currency -> Q Exp)
-> (Currency -> Q (TExp Currency)) -> Lift Currency
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Currency -> Q (TExp Currency)
$cliftTyped :: Currency -> Q (TExp Currency)
lift :: Currency -> Q Exp
$clift :: Currency -> Q Exp
TH.Lift)


-- | 'Show' instance for 'Currency'.
--
-- >>> MkCurrency "USD"
-- USD
instance Show Currency where
  show :: Currency -> String
show (MkCurrency Text
x) = Text -> String
T.unpack Text
x


-- | 'IsString' instance for 'Currency'.
--
-- >>> "USD" :: Currency
-- USD
instance IsString Currency where
  fromString :: String -> Currency
fromString =  (String -> Currency)
-> (Currency -> Currency) -> Either String Currency -> Currency
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Currency
forall a. HasCallStack => String -> a
error Currency -> Currency
forall a. a -> a
id (Either String Currency -> Currency)
-> (String -> Either String Currency) -> String -> Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency (Text -> Either String Currency)
-> (String -> Text) -> String -> Either String Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack


-- | 'Aeson.FromJSON' instance for 'Currency'.
--
-- >>> Aeson.eitherDecode "\"\"" :: Either String Currency
-- Left "Error in $: Currency code error! Expecting at least 3 uppercase characters, but received: \"\""
-- >>> Aeson.eitherDecode "\"ABC\"" :: Either String Currency
-- Right ABC
instance Aeson.FromJSON Currency where
  parseJSON :: Value -> Parser Currency
parseJSON = String -> (Text -> Parser Currency) -> Value -> Parser Currency
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Currency" ((Text -> Parser Currency) -> Value -> Parser Currency)
-> (Text -> Parser Currency) -> Value -> Parser Currency
forall a b. (a -> b) -> a -> b
$ (String -> Parser Currency)
-> (Currency -> Parser Currency)
-> Either String Currency
-> Parser Currency
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Currency
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Currency -> Parser Currency
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Currency -> Parser Currency)
-> (Text -> Either String Currency) -> Text -> Parser Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency


-- | 'Aeson.ToJSON' instance for 'Currency'.
--
-- >>> Aeson.encode (MkCurrency "USD")
-- "\"USD\""
instance Aeson.ToJSON Currency where
  toJSON :: Currency -> Value
toJSON (MkCurrency Text
c) = Text -> Value
Aeson.String Text
c


-- * Constructors
-- &constructors


-- | Smart constructor for 'Currency' values within 'MonadError' context.
--
-- >>> currency "" :: Either String Currency
-- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"\""
-- >>> currency " " :: Either String Currency
-- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" \""
-- >>> currency "AB" :: Either String Currency
-- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"AB\""
-- >>> currency " ABC " :: Either String Currency
-- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" ABC \""
-- >>> currency "ABC" :: Either String Currency
-- Right ABC
currency :: MonadError String m => T.Text -> m Currency
currency :: Text -> m Currency
currency Text
x = (ParseErrorBundle Text Void -> m Currency)
-> (Text -> m Currency)
-> Either (ParseErrorBundle Text Void) Text
-> m Currency
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
  (m Currency -> ParseErrorBundle Text Void -> m Currency
forall a b. a -> b -> a
const (m Currency -> ParseErrorBundle Text Void -> m Currency)
-> (String -> m Currency)
-> String
-> ParseErrorBundle Text Void
-> m Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Currency
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ParseErrorBundle Text Void -> m Currency)
-> String -> ParseErrorBundle Text Void -> m Currency
forall a b. (a -> b) -> a -> b
$ String
"Currency code error! Expecting at least 3 uppercase characters, but received: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
x)
  (Currency -> m Currency
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Currency -> m Currency)
-> (Text -> Currency) -> Text -> m Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Currency
MkCurrency)
  (Parsec Void Text Text
-> String -> Text -> Either (ParseErrorBundle Text Void) Text
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.runParser Parsec Void Text Text
currencyCodeParser String
"Currency Code" Text
x)


-- | Smart constructor for 'Currency' values within 'MonadFail' context.
--
-- >>> currencyFail "" :: Maybe Currency
-- Nothing
-- >>> currencyFail "US" :: Maybe Currency
-- Nothing
-- >>> currencyFail "usd" :: Maybe Currency
-- Nothing
-- >>> currencyFail "USD" :: Maybe Currency
-- Just USD
currencyFail :: MonadFail m => T.Text -> m Currency
currencyFail :: Text -> m Currency
currencyFail = (String -> m Currency)
-> (Currency -> m Currency) -> Either String Currency -> m Currency
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m Currency
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Currency -> m Currency
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Currency -> m Currency)
-> (Text -> Either String Currency) -> Text -> m Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Currency
forall (m :: * -> *). MonadError String m => Text -> m Currency
currency


-- * Auxiliaries
-- &auxiliaries


-- | Parser that parses currency codes.
--
-- >>> MP.runParser currencyCodeParser "Example" ""
-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})
-- >>> MP.runParser currencyCodeParser "Example" " "
-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})
-- >>> MP.runParser currencyCodeParser "Example" "a"
-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens ('a' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = "a", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})
-- >>> MP.runParser currencyCodeParser "Example" "A"
-- Left (ParseErrorBundle {bundleErrors = TrivialError 1 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "A", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})
-- >>> MP.runParser currencyCodeParser "Example" "AB"
-- Left (ParseErrorBundle {bundleErrors = TrivialError 2 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "AB", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})
-- >>> MP.runParser currencyCodeParser "Example" "ABC"
-- Right "ABC"
currencyCodeParser :: MP.Parsec Void T.Text T.Text
currencyCodeParser :: Parsec Void Text Text
currencyCodeParser = do
  String
mandatory <- Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
MP.count Int
3 ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
parserChar
  String
optionals <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
MP.many ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
parserChar
  Text -> Parsec Void Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parsec Void Text Text)
-> (String -> Text) -> String -> Parsec Void Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Parsec Void Text Text)
-> String -> Parsec Void Text Text
forall a b. (a -> b) -> a -> b
$ String
mandatory String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
optionals
  where
    validChars :: String
validChars = [Char
'A'..Char
'Z']
    parserChar :: ParsecT Void Text Identity (Token Text)
parserChar = [Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
MP.oneOf String
[Token Text]
validChars


newtype CurrencyPair = MkCurrencyPair { CurrencyPair -> (Currency, Currency)
unCurrencyPair :: (Currency, Currency) }
  deriving (CurrencyPair -> CurrencyPair -> Bool
(CurrencyPair -> CurrencyPair -> Bool)
-> (CurrencyPair -> CurrencyPair -> Bool) -> Eq CurrencyPair
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CurrencyPair -> CurrencyPair -> Bool
$c/= :: CurrencyPair -> CurrencyPair -> Bool
== :: CurrencyPair -> CurrencyPair -> Bool
$c== :: CurrencyPair -> CurrencyPair -> Bool
Eq, Int -> CurrencyPair -> Int
CurrencyPair -> Int
(Int -> CurrencyPair -> Int)
-> (CurrencyPair -> Int) -> Hashable CurrencyPair
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: CurrencyPair -> Int
$chash :: CurrencyPair -> Int
hashWithSalt :: Int -> CurrencyPair -> Int
$chashWithSalt :: Int -> CurrencyPair -> Int
Hashable, Eq CurrencyPair
Eq CurrencyPair
-> (CurrencyPair -> CurrencyPair -> Ordering)
-> (CurrencyPair -> CurrencyPair -> Bool)
-> (CurrencyPair -> CurrencyPair -> Bool)
-> (CurrencyPair -> CurrencyPair -> Bool)
-> (CurrencyPair -> CurrencyPair -> Bool)
-> (CurrencyPair -> CurrencyPair -> CurrencyPair)
-> (CurrencyPair -> CurrencyPair -> CurrencyPair)
-> Ord CurrencyPair
CurrencyPair -> CurrencyPair -> Bool
CurrencyPair -> CurrencyPair -> Ordering
CurrencyPair -> CurrencyPair -> CurrencyPair
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
min :: CurrencyPair -> CurrencyPair -> CurrencyPair
$cmin :: CurrencyPair -> CurrencyPair -> CurrencyPair
max :: CurrencyPair -> CurrencyPair -> CurrencyPair
$cmax :: CurrencyPair -> CurrencyPair -> CurrencyPair
>= :: CurrencyPair -> CurrencyPair -> Bool
$c>= :: CurrencyPair -> CurrencyPair -> Bool
> :: CurrencyPair -> CurrencyPair -> Bool
$c> :: CurrencyPair -> CurrencyPair -> Bool
<= :: CurrencyPair -> CurrencyPair -> Bool
$c<= :: CurrencyPair -> CurrencyPair -> Bool
< :: CurrencyPair -> CurrencyPair -> Bool
$c< :: CurrencyPair -> CurrencyPair -> Bool
compare :: CurrencyPair -> CurrencyPair -> Ordering
$ccompare :: CurrencyPair -> CurrencyPair -> Ordering
$cp1Ord :: Eq CurrencyPair
Ord, CurrencyPair -> Q Exp
CurrencyPair -> Q (TExp CurrencyPair)
(CurrencyPair -> Q Exp)
-> (CurrencyPair -> Q (TExp CurrencyPair)) -> Lift CurrencyPair
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: CurrencyPair -> Q (TExp CurrencyPair)
$cliftTyped :: CurrencyPair -> Q (TExp CurrencyPair)
lift :: CurrencyPair -> Q Exp
$clift :: CurrencyPair -> Q Exp
TH.Lift)


-- | 'Show' instance for currency pairs.
--
-- >>> MkCurrencyPair ("EUR", "USD")
-- EUR/USD
instance Show CurrencyPair where
  show :: CurrencyPair -> String
show (MkCurrencyPair (Currency
x, Currency
y)) = Currency -> String
forall a. Show a => a -> String
show Currency
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Currency -> String
forall a. Show a => a -> String
show Currency
y


toTuple :: CurrencyPair -> (Currency, Currency)
toTuple :: CurrencyPair -> (Currency, Currency)
toTuple = CurrencyPair -> (Currency, Currency)
unCurrencyPair


baseCurrency :: CurrencyPair -> Currency
baseCurrency :: CurrencyPair -> Currency
baseCurrency = (Currency, Currency) -> Currency
forall a b. (a, b) -> a
fst ((Currency, Currency) -> Currency)
-> (CurrencyPair -> (Currency, Currency))
-> CurrencyPair
-> Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencyPair -> (Currency, Currency)
unCurrencyPair


quoteCurrency :: CurrencyPair -> Currency
quoteCurrency :: CurrencyPair -> Currency
quoteCurrency = (Currency, Currency) -> Currency
forall a b. (a, b) -> b
snd ((Currency, Currency) -> Currency)
-> (CurrencyPair -> (Currency, Currency))
-> CurrencyPair
-> Currency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CurrencyPair -> (Currency, Currency)
unCurrencyPair


currencyPair :: MonadError String m => Currency -> Currency -> m CurrencyPair
currencyPair :: Currency -> Currency -> m CurrencyPair
currencyPair Currency
c1 Currency
c2
  | Currency
c1 Currency -> Currency -> Bool
forall a. Eq a => a -> a -> Bool
== Currency
c2 = String -> m CurrencyPair
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m CurrencyPair) -> String -> m CurrencyPair
forall a b. (a -> b) -> a -> b
$ String
"Can not create currency pair from same currencies: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Currency -> String
forall a. Show a => a -> String
show Currency
c1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Currency -> String
forall a. Show a => a -> String
show Currency
c2
  | Bool
otherwise = CurrencyPair -> m CurrencyPair
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Currency, Currency) -> CurrencyPair
MkCurrencyPair (Currency
c1, Currency
c2))


currencyPairFail :: MonadFail m => Currency -> Currency -> m CurrencyPair
currencyPairFail :: Currency -> Currency -> m CurrencyPair
currencyPairFail = ((String -> m CurrencyPair)
-> (CurrencyPair -> m CurrencyPair)
-> Either String CurrencyPair
-> m CurrencyPair
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m CurrencyPair
forall (m :: * -> *) a. MonadFail m => String -> m a
fail CurrencyPair -> m CurrencyPair
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String CurrencyPair -> m CurrencyPair)
-> (Currency -> Either String CurrencyPair)
-> Currency
-> m CurrencyPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Currency -> Either String CurrencyPair)
 -> Currency -> m CurrencyPair)
-> (Currency -> Currency -> Either String CurrencyPair)
-> Currency
-> Currency
-> m CurrencyPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Currency -> Currency -> Either String CurrencyPair
forall (m :: * -> *).
MonadError String m =>
Currency -> Currency -> m CurrencyPair
currencyPair