diff --git a/nix/configuration.nix b/nix/configuration.nix index 6bd81b7a..50d470f6 100644 --- a/nix/configuration.nix +++ b/nix/configuration.nix @@ -6,7 +6,7 @@ }: let vi = import ./../pub/vi/nix/default.nix {}; # xkb = pkgs.writeText "xkb-layout" (builtins.readFile ./../cfg/.Xmodmap); - yewtube = import ./yewtube.nix; + # yewtube = import ./yewtube.nix; qmk-setup = import ./qmk-setup.nix; lockCmd = "${pkgs.swaylock}/bin/swaylock --color=000000"; home-manager = builtins.fetchTarball { diff --git a/prv b/prv index 86c1bfd2..7032004f 160000 --- a/prv +++ b/prv @@ -1 +1 @@ -Subproject commit 86c1bfd2946a2c24335f5918e6eeb863c9fd8dfe +Subproject commit 7032004f4dd8d96031d6e60019d3bf7215c6f551 diff --git a/pub/bfx/bfx.cabal b/pub/bfx/bfx.cabal index 01c20de5..3d08150d 100644 --- a/pub/bfx/bfx.cabal +++ b/pub/bfx/bfx.cabal @@ -128,7 +128,6 @@ library Bfx.Data.GetOrders Bfx.Data.Kind Bfx.Data.MarketAveragePrice - Bfx.Data.Metro Bfx.Data.SubmitOrder Bfx.Data.Type Bfx.Data.Wallets @@ -140,7 +139,6 @@ library Bfx.Indicator.Ma Bfx.Indicator.Tr Bfx.Math - Bfx.Orphan Bfx.Parser Bfx.Rpc.Generic Bfx.Util @@ -154,6 +152,7 @@ test-suite bfx-test Bfx.Data.CancelOrderMultiSpec Bfx.Data.SubmitOrderSpec Bfx.Data.TypeSpec + Bfx.MathSpec Bfx.TestEnv BfxSpec Paths_bfx @@ -180,7 +179,6 @@ test-suite bfx-test Bfx.Data.GetOrders Bfx.Data.Kind Bfx.Data.MarketAveragePrice - Bfx.Data.Metro Bfx.Data.SubmitOrder Bfx.Data.Type Bfx.Data.Wallets @@ -192,7 +190,6 @@ test-suite bfx-test Bfx.Indicator.Ma Bfx.Indicator.Tr Bfx.Math - Bfx.Orphan Bfx.Parser Bfx.Rpc.Generic Bfx.Util diff --git a/pub/bfx/src/Bfx.hs b/pub/bfx/src/Bfx.hs index 2bcf74ae..471137e2 100644 --- a/pub/bfx/src/Bfx.hs +++ b/pub/bfx/src/Bfx.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx @@ -43,63 +42,59 @@ import Bfx.Import.Internal as X import Bfx.Indicator.Atr as X import Bfx.Indicator.Ma as X import Bfx.Indicator.Tr as X -import qualified Bfx.Math as Math import qualified Bfx.Rpc.Generic as Generic import qualified Data.Map as Map import qualified Data.Set as Set platformStatus :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => m PltStatus platformStatus = - Generic.pub @'PlatformStatus [] () + Generic.pub @'PlatformStatus mempty emptyReq symbolsDetails :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => m (Map CurrencyPair CurrencyPairConf) symbolsDetails = - Generic.pub @'SymbolsDetails [] () + Generic.pub @'SymbolsDetails mempty emptyReq marketAveragePrice :: - forall (act :: BuyOrSell) m. - ( MonadUnliftIO m, - MonadThrow m, - ToRequestParam (Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| act)), - Typeable act + ( MonadThrow m, + MonadUnliftIO m ) => - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| act) -> - CurrencyPair -> - m (Money (Tags 'Unsigned |+| 'QuotePerBase |+| act)) -marketAveragePrice amt sym = + MarketAveragePrice.Request -> + m QuotePerBase +marketAveragePrice args = Generic.pub @'MarketAveragePrice [ SomeQueryParam "amount" amt, SomeQueryParam "symbol" sym ] - MarketAveragePrice.Request - { MarketAveragePrice.amount = amt, - MarketAveragePrice.symbol = sym - } + args + where + amt = + ( MarketAveragePrice.buyOrSell args, + MarketAveragePrice.baseAmount args + ) + sym = + MarketAveragePrice.symbol args feeSummary :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> m FeeSummary.Response feeSummary env = - Generic.prv - @'FeeSummary - env - (mempty :: Map Int Int) + Generic.prv @'FeeSummary env emptyReq wallets :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> m @@ -108,63 +103,60 @@ wallets :: (Map Wallets.WalletType Wallets.Response) ) wallets env = - Generic.prv - @'Wallets - env - (mempty :: Map Int Int) + Generic.prv @'Wallets env emptyReq spendableExchangeBalance :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> CurrencyCode -> - m (Money (Tags 'Unsigned |+| 'MoneyAmount)) + m MoneyAmount spendableExchangeBalance env cc = - maybe (Tagged 0) Wallets.availableBalance + maybe (MoneyAmount 0) Wallets.availableBalance . Map.lookup Wallets.Exchange . Map.findWithDefault mempty cc <$> wallets env retrieveOrders :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> GetOrders.Options -> - m (Map OrderId (SomeOrder 'Remote)) + m (Map OrderId Order) retrieveOrders = Generic.prv @'RetrieveOrders ordersHistory :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> GetOrders.Options -> - m (Map OrderId (SomeOrder 'Remote)) + m (Map OrderId Order) ordersHistory = Generic.prv @'OrdersHistory getOrders :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> GetOrders.Options -> - m (Map OrderId (SomeOrder 'Remote)) + m (Map OrderId Order) getOrders = - getOrders' 0 + getOrdersRec 0 -getOrders' :: - ( MonadUnliftIO m, - MonadThrow m +getOrdersRec :: + ( MonadThrow m, + MonadUnliftIO m ) => Natural -> Env -> GetOrders.Options -> - m (Map OrderId (SomeOrder 'Remote)) -getOrders' attempt env opts = do + m (Map OrderId Order) +getOrdersRec attempt env opts = do xs0 <- retrieveOrders env opts xs1 <- ordersHistory env opts let xs = xs1 <> xs0 @@ -176,15 +168,15 @@ getOrders' attempt env opts = do then pure xs else do liftIO $ threadDelay 250000 - getOrders' (attempt + 1) env opts + getOrdersRec (attempt + 1) env opts getOrder :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderId -> - m (SomeOrder 'Remote) + m Order getOrder env id0 = do mOrder <- Map.lookup id0 @@ -192,146 +184,102 @@ getOrder env id0 = do maybe (throw $ ErrorMissingOrder id0) pure mOrder verifyOrder :: - forall act m. - ( MonadUnliftIO m, - MonadThrow m, - SingI act + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderId -> - SubmitOrder.Request act -> - m (Order act 'Remote) + SubmitOrder.Request -> + m Order verifyOrder env id0 req = do - someRemOrd@(SomeOrder remSing remOrd) <- getOrder env id0 - case testEquality remSing locSing of - Nothing -> throw $ ErrorOrderState someRemOrd - Just Refl -> do - let locOrd = - Order - { orderId = - id0, - orderGroupId = - SubmitOrder.groupId opts, - orderClientId = - SubmitOrder.clientId opts - <|> orderClientId remOrd, - orderAmount = - SubmitOrder.amount req, - orderSymbol = - SubmitOrder.symbol req, - orderRate = - SubmitOrder.rate req, - orderStatus = - orderStatus remOrd - } - if remOrd == locOrd - then pure remOrd - else - throw - $ ErrorUnverifiedOrder - (SomeOrder locSing $ coerce locOrd) - someRemOrd + remOrd <- getOrder env id0 + let locOrd = + Order + { orderId = id0, + orderGroupId = + SubmitOrder.groupId opts, + orderClientId = + SubmitOrder.clientId opts + <|> orderClientId remOrd, + orderBaseAmount = + SubmitOrder.baseAmount req, + orderSymbol = + SubmitOrder.symbol req, + orderRate = + SubmitOrder.rate req, + orderStatus = + orderStatus remOrd, + orderBuyOrSell = + SubmitOrder.buyOrSell req, + orderLocalOrRemote = + Local + } + if remOrd == locOrd {orderLocalOrRemote = Remote} + then pure remOrd + else + throw + $ ErrorUnverifiedOrder + (Tagged @'Local locOrd) + (Tagged @'Remote remOrd) where opts = SubmitOrder.options req - locSing = sing :: Sing act submitOrder :: - forall (bos :: BuyOrSell) m. - ( MonadUnliftIO m, - MonadThrow m, - ToRequestParam (Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos)), - ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)), - Typeable bos, - SingI bos + ( MonadThrow m, + MonadUnliftIO m ) => Env -> - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos) -> - CurrencyPair -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos) -> - SubmitOrder.Options bos -> - m (Order bos 'Remote) -submitOrder env amt sym rate opts = do - let req = - SubmitOrder.Request - { SubmitOrder.amount = amt, - SubmitOrder.symbol = sym, - SubmitOrder.rate = rate, - SubmitOrder.options = opts - } - order :: Order bos 'Remote <- Generic.prv @'SubmitOrder env req + SubmitOrder.Request -> + m Order +submitOrder env req = do + order <- Generic.prv @'SubmitOrder env req verifyOrder env (orderId order) req submitOrderMaker :: - forall (bos :: BuyOrSell) m. - ( MonadUnliftIO m, - MonadThrow m, - ToRequestParam (Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos)), - ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)), - MoneyTags (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos), - MoneyTags (Tags 'Unsigned |+| 'QuotePerBase |+| bos), - HasTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos) + ( MonadThrow m, + MonadUnliftIO m ) => Env -> - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos) -> - CurrencyPair -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos) -> - SubmitOrder.Options bos -> - m (Order bos 'Remote) -submitOrderMaker env amt sym rate0 opts0 = - submitOrderMakerRec @bos env amt sym 0 rate0 opts - where - opts = - opts0 - { SubmitOrder.flags = - Set.insert PostOnly $ SubmitOrder.flags opts0 - } + SubmitOrder.Request -> + m Order +submitOrderMaker env = + submitOrderMakerRec 0 env + . (#options . #flags %~ Set.insert PostOnly) submitOrderMakerRec :: - forall (bos :: BuyOrSell) m. - ( MonadUnliftIO m, - MonadThrow m, - ToRequestParam (Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos)), - ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)), - MoneyTags (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos), - MoneyTags (Tags 'Unsigned |+| 'QuotePerBase |+| bos), - HasTag bos (Tags 'Unsigned |+| 'QuotePerBase |+| bos) + ( MonadThrow m, + MonadUnliftIO m ) => - Env -> - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos) -> - CurrencyPair -> Int -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos) -> - SubmitOrder.Options bos -> - m (Order bos 'Remote) -submitOrderMakerRec env amt sym attempt rate opts = do - order :: Order bos 'Remote <- submitOrder @bos env amt sym rate opts + Env -> + SubmitOrder.Request -> + m Order +submitOrderMakerRec attempt env req = do + order <- submitOrder env req if orderStatus order /= PostOnlyCancelled then pure order else do - when (attempt >= 10) - . throw - . ErrorOrderState - $ SomeOrder (sing :: Sing bos) order - newRate <- Math.tweakMakerRate rate - submitOrderMakerRec env amt sym (attempt + 1) newRate opts + when (attempt >= 10) . throw $ ErrorRemoteOrderState order + next <- tweakQuotePerBase (req ^. #buyOrSell) (req ^. #rate) + submitOrderMakerRec (attempt + 1) env $ req & #rate .~ next cancelOrderMulti :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> CancelOrderMulti.Request -> - m (Map OrderId (SomeOrder 'Remote)) + m (Map OrderId Order) cancelOrderMulti = Generic.prv @'CancelOrderMulti cancelOrderById :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderId -> - m (SomeOrder 'Remote) + m Order cancelOrderById env id0 = do mOrder <- Map.lookup id0 @@ -342,13 +290,13 @@ cancelOrderById env id0 = do maybe (throw $ ErrorMissingOrder id0) pure mOrder cancelOrderByClientId :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderClientId -> UTCTime -> - m (Maybe (SomeOrder 'Remote)) + m (Maybe Order) cancelOrderByClientId env cid utc = listToMaybe . elems @@ -359,141 +307,152 @@ cancelOrderByClientId env cid utc = ) cancelOrderByGroupId :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderGroupId -> - m (Map OrderId (SomeOrder 'Remote)) + m (Map OrderId Order) cancelOrderByGroupId env gid = do cancelOrderMulti env . CancelOrderMulti.ByOrderGroupId $ Set.singleton gid submitCounterOrder :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderId -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Base) -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Quote) -> - Money (Tags 'Unsigned |+| 'ProfitRate) -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + CounterRates -> + SubmitOrder.Options -> + m Order submitCounterOrder = - submitCounterOrder' submitOrder + mkSubmitCounterOrder submitOrder submitCounterOrderMaker :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> OrderId -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Base) -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Quote) -> - Money (Tags 'Unsigned |+| 'ProfitRate) -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + CounterRates -> + SubmitOrder.Options -> + m Order submitCounterOrderMaker = - submitCounterOrder' submitOrderMaker + mkSubmitCounterOrder submitOrderMaker -submitCounterOrder' :: - ( MonadUnliftIO m, - MonadThrow m +mkSubmitCounterOrder :: + ( MonadThrow m, + MonadUnliftIO m ) => - ( Env -> - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| 'Sell) -> - CurrencyPair -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + ( Env -> SubmitOrder.Request -> m Order ) -> Env -> OrderId -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Base) -> - Money (Tags 'Unsigned |+| 'FeeRate |+| 'Quote) -> - Money (Tags 'Unsigned |+| 'ProfitRate) -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) -submitCounterOrder' submit env id0 feeB feeQ prof opts = do - someRemOrd@(SomeOrder remSing remOrder) <- getOrder env id0 - case remSing of - SBuy | orderStatus remOrder == Executed -> do - (_, exitAmt, exitRate) <- - Math.newCounterOrder - (tag @'Gross (orderAmount remOrder)) - (tag @'Net (orderRate remOrder)) - feeB - feeQ - (tag @'Quote . tag @'Buy $ tag @'Net prof) + CounterRates -> + SubmitOrder.Options -> + m Order +mkSubmitCounterOrder submit env id0 rates opts = do + remOrder <- getOrder env id0 + let sym = orderSymbol remOrder + case orderBuyOrSell remOrder of + Buy | orderStatus remOrder == Executed -> do + counter <- + newCounterOrder + CounterArgs + { counterArgsEnterGrossBaseGain = + orderBaseAmount remOrder, + counterArgsEnterQuotePerBase = + orderRate remOrder, + counterArgsRates = + rates + } + let exitAmt = counterExitNetBaseLoss counter + let exitRate = counterExitQuotePerBase counter currentRate <- - marketAveragePrice (unTag @'Net exitAmt) - $ orderSymbol remOrder + marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Sell, + MarketAveragePrice.baseAmount = exitAmt, + MarketAveragePrice.symbol = sym + } submit env - (unTag @'Net exitAmt) - (orderSymbol remOrder) - (max exitRate currentRate) - opts + SubmitOrder.Request + { SubmitOrder.buyOrSell = Sell, + SubmitOrder.baseAmount = exitAmt, + SubmitOrder.symbol = sym, + SubmitOrder.rate = max exitRate currentRate, + SubmitOrder.options = opts + } _ -> throw - $ ErrorOrderState someRemOrd + $ ErrorRemoteOrderState remOrder -dumpIntoQuote' :: - ( MonadUnliftIO m, - MonadThrow m +mkDumpIntoQuote :: + ( MonadThrow m, + MonadUnliftIO m ) => - ( Env -> - Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| 'Sell) -> - CurrencyPair -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + ( Env -> SubmitOrder.Request -> m Order ) -> Env -> CurrencyPair -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) -dumpIntoQuote' submit env sym opts = do + SubmitOrder.Options -> + m Order +mkDumpIntoQuote submit env sym opts = do amt <- spendableExchangeBalance env (currencyPairBase sym) - rate <- marketAveragePrice (tag @'Sell $ tag @'Base amt) sym - catchAny - (submit env (tag @'Sell $ tag @'Base amt) sym rate opts) + rate <- + marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Sell, + MarketAveragePrice.baseAmount = amt, + MarketAveragePrice.symbol = sym + } + let mkSubmit baseAmount = + submit + env + SubmitOrder.Request + { SubmitOrder.buyOrSell = Sell, + SubmitOrder.baseAmount = baseAmount, + SubmitOrder.symbol = sym, + SubmitOrder.rate = rate, + SubmitOrder.options = opts + } + catchAny (mkSubmit amt) . const - $ do - newAmt <- Math.tweakMoneyPip (tag @'Sell $ tag @'Base amt) - submit env newAmt sym rate opts + $ tweakMoneyAmount Sell amt + >>= mkSubmit dumpIntoQuote :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> CurrencyPair -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + SubmitOrder.Options -> + m Order dumpIntoQuote = - dumpIntoQuote' submitOrder + mkDumpIntoQuote submitOrder dumpIntoQuoteMaker :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> CurrencyPair -> - SubmitOrder.Options 'Sell -> - m (Order 'Sell 'Remote) + SubmitOrder.Options -> + m Order dumpIntoQuoteMaker = - dumpIntoQuote' submitOrderMaker + mkDumpIntoQuote submitOrderMaker netWorth :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => Env -> CurrencyCode -> - m (Money (Tags 'Unsigned |+| 'MoneyAmount)) + m MoneyAmount netWorth env ccq = do -- Simplify fees (assume it's alwayus Maker and Crypto2Crypto) fee <- FeeSummary.makerCrypto2CryptoFee <$> feeSummary env @@ -502,42 +461,39 @@ netWorth env ccq = do res <- foldrM ( \(ccb, bs1) totalAcc -> do - let localAcc :: Money (Tags 'Unsigned |+| 'MoneyAmount) = + let localAcc = foldr ( \amt acc -> - Wallets.balance amt `addMoney` acc + unMoneyAmount (Wallets.balance amt) + acc ) - (Tagged 0) + 0 $ Map.elems bs1 if ccb == ccq - then pure $ totalAcc `addMoney` localAcc + then pure $ totalAcc + localAcc else do -- In this case we are dealing with Base -- money, so we need transform from Quote sym <- currencyPairCon (from ccb) $ Tagged @'Quote ccq - baseMoney :: - Money (Tags 'Unsigned |+| 'Base |+| 'Sell |+| 'MoneyAmount) <- - fmap (tag @'Base . tag @'Sell) $ roundMoney localAcc - if baseMoney == Tagged 0 + baseMoney <- roundMoneyAmount $ MoneyAmount localAcc + if baseMoney == MoneyAmount 0 then pure totalAcc else do - price :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) <- - marketAveragePrice baseMoney sym + price <- + marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Sell, + MarketAveragePrice.baseAmount = baseMoney, + MarketAveragePrice.symbol = sym + } pure - . addMoney totalAcc - . unTag @'Net - . unTag @'Sell - . unTag @'Quote - $ deductFee - @(Tags 'Unsigned |+| 'FeeRate |+| 'Maker) - fee - ( tag @'Gross - $ exchangeMoney @(Tags 'Unsigned |+| 'Sell) - price - baseMoney + $ ( totalAcc + + ( unMoneyAmount baseMoney + * unQuotePerBase price + * (1 - unFeeRate fee) + ) ) ) - (Tagged 0) + 0 . filter ( \(cc, _) -> fromRight @@ -548,11 +504,11 @@ netWorth env ccq = do || (cc == ccq) ) $ Map.assocs xs0 - roundMoney res + roundMoneyAmount $ MoneyAmount res candlesLast :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => CandleTimeFrame -> CurrencyPair -> @@ -575,8 +531,8 @@ candlesLast tf sym opts = } candlesHist :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => CandleTimeFrame -> CurrencyPair -> @@ -599,12 +555,12 @@ candlesHist tf sym opts = } tickers :: - ( MonadUnliftIO m, - MonadThrow m + ( MonadThrow m, + MonadUnliftIO m ) => m (Map CurrencyPair Ticker) tickers = Generic.pub @'Tickers [ SomeQueryParam "symbols" ("ALL" :: Text) ] - () + emptyReq diff --git a/pub/bfx/src/Bfx/Class/FromRpc.hs b/pub/bfx/src/Bfx/Class/FromRpc.hs index df029dcb..26ff51c2 100644 --- a/pub/bfx/src/Bfx/Class/FromRpc.hs +++ b/pub/bfx/src/Bfx/Class/FromRpc.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Class.FromRpc @@ -9,11 +7,11 @@ where import qualified Bfx.Data.FeeSummary as FeeSummary import Bfx.Data.Kind -import Bfx.Data.Metro import Bfx.Data.Type import qualified Bfx.Data.Wallets as Wallets import Bfx.Data.Web import Bfx.Import.External +import Bfx.Math import Bfx.Parser import Data.Aeson.Lens import qualified Data.Map as Map @@ -36,7 +34,7 @@ instance FromRpc 'PlatformStatus PltStatus where 0 -> Right PltMaintenance _ -> Left "Incorrect PltStatus" -instance FromRpc 'CancelOrderMulti (Map OrderId (SomeOrder 'Remote)) where +instance FromRpc 'CancelOrderMulti (Map OrderId Order) where fromRpc (RawResponse raw) = do xs <- maybeToRight @@ -45,41 +43,20 @@ instance FromRpc 'CancelOrderMulti (Map OrderId (SomeOrder 'Remote)) where ^? nth 4 parseOrderMap xs -instance - FromRpc - 'RetrieveOrders - (Map OrderId (SomeOrder 'Remote)) - where +instance FromRpc 'RetrieveOrders (Map OrderId Order) where fromRpc (RawResponse raw) = parseOrderMap raw -instance - FromRpc - 'OrdersHistory - (Map OrderId (SomeOrder 'Remote)) - where +instance FromRpc 'OrdersHistory (Map OrderId Order) where fromRpc (RawResponse raw) = parseOrderMap raw -instance (SingI act) => FromRpc 'SubmitOrder (Order act 'Remote) where +instance FromRpc 'SubmitOrder Order where fromRpc (RawResponse raw) = do - rawOrder <- - maybeToRight - "Order is missing" - $ raw - ^? nth 4 - . nth 0 - SomeOrder orderSing order <- parseOrder rawOrder - case testEquality (sing :: Sing act) orderSing of - Nothing -> Left "Incorrect ExchangeAction" - Just Refl -> pure order + rawOrder <- maybeToRight "Order is missing" $ raw ^? nth 4 . nth 0 + parseOrder rawOrder -instance - ( RateTags tags, - Ratio (IntRep tags) ~ a - ) => - FromRpc 'MarketAveragePrice (Tagged tags a) - where +instance FromRpc 'MarketAveragePrice QuotePerBase where fromRpc (RawResponse raw) = do x <- maybeToRight @@ -87,30 +64,24 @@ instance (toRational <$> raw ^? nth 0 . _Number) first (const $ "QuotePerBase is invalid " <> inspect x) . roundQuotePerBase - . Tagged + . QuotePerBase $ unsafeFrom @Rational @(Ratio Natural) x instance FromRpc 'FeeSummary FeeSummary.Response where fromRpc (RawResponse raw) = do - x0 <- parse 0 0 (money @'Maker) "makerCrypto2CryptoFee" - x1 <- parse 0 1 (money @'Maker) "makerCrypto2StableFee" - x2 <- parse 0 2 (money @'Maker) "makerCrypto2FiatFee" + x0 <- parse 0 0 rate "makerCrypto2CryptoFee" + x1 <- parse 0 1 rate "makerCrypto2StableFee" + x2 <- parse 0 2 rate "makerCrypto2FiatFee" x3 <- parse 0 5 (pure . RebateRate) "makerDerivativeRebate" - x4 <- parse 1 0 (money @'Taker) "takerCrypto2CryptoFee" - x5 <- parse 1 1 (money @'Taker) "takerCrypto2StableFee" - x6 <- parse 1 2 (money @'Taker) "takerCrypto2FiatFee" - x7 <- parse 1 5 (money @'Taker) "takerDerivativeFee" - pure - $ FeeSummary.Response x0 x1 x2 x3 x4 x5 x6 x7 + x4 <- parse 1 0 rate "takerCrypto2CryptoFee" + x5 <- parse 1 1 rate "takerCrypto2StableFee" + x6 <- parse 1 2 rate "takerCrypto2FiatFee" + x7 <- parse 1 5 rate "takerDerivativeFee" + pure $ FeeSummary.Response x0 x1 x2 x3 x4 x5 x6 x7 where - money :: - forall tag. - ( CashTags (Tags 'Unsigned |+| 'FeeRate |+| tag) - ) => - Rational -> - Either Text (Money (Tags 'Unsigned |+| 'FeeRate |+| tag)) - money = - bimap inspect Tagged + rate :: Rational -> Either Text FeeRate + rate = + bimap inspect FeeRate . tryFrom @Rational @(Ratio Natural) parse :: Int -> @@ -199,11 +170,12 @@ instance ^? key "maximum_order_size" . _String maxOrderAmt <- - first + bimap ( const $ "Max Order Size is invalid " <> inspect maxOrderAmt0 ) + MoneyAmount $ parseRatio maxOrderAmt0 minOrderAmt0 <- maybeToRight "Min Order Size is missing" @@ -211,11 +183,12 @@ instance ^? key "minimum_order_size" . _String minOrderAmt <- - first + bimap ( const $ "Min Order Size is invalid " <> inspect minOrderAmt0 ) + MoneyAmount $ parseRatio minOrderAmt0 pure ( sym, @@ -223,8 +196,8 @@ instance { currencyPairPrecision = prec, currencyPairInitMargin = initMargin, currencyPairMinMargin = minMargin, - currencyPairMaxOrderAmt = Tagged maxOrderAmt, - currencyPairMinOrderAmt = Tagged minOrderAmt + currencyPairMaxOrderBaseAmt = maxOrderAmt, + currencyPairMinOrderBaseAmt = minOrderAmt } ) @@ -272,24 +245,24 @@ instance (x ^? nth 1 . _String) balance <- first inspect - . roundMoney - . Tagged + . roundMoneyAmount + . MoneyAmount . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "Balance is missing" (toRational <$> x ^? nth 2 . _Number) unsettledInterest <- first inspect - . roundMoney - . Tagged + . roundMoneyAmount + . MoneyAmount . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "UnsettledBalance is missing" (toRational <$> x ^? nth 3 . _Number) availableBalance <- first inspect - . roundMoney - . Tagged + . roundMoneyAmount + . MoneyAmount . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "AvailableBalance is missing" @@ -361,7 +334,7 @@ instance FromRpc 'Tickers (Map CurrencyPair Ticker) where bid <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "Bid is missing" @@ -369,15 +342,15 @@ instance FromRpc 'Tickers (Map CurrencyPair Ticker) where ask0 <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "Ask is missing" (toRational <$> x ^? nth 3 . _Number) vol <- first inspect - . roundMoney - . Tagged + . roundMoneyAmount + . MoneyAmount . unsafeFrom @Rational @(Ratio Natural) =<< maybeToRight "Volume is missing" @@ -386,8 +359,8 @@ instance FromRpc 'Tickers (Map CurrencyPair Ticker) where ( sym, Ticker { tickerSymbol = sym, - tickerVolume = vol, - tickerBid = bid, - tickerAsk = ask0 + tickerBaseVolume = vol, + tickerBidBuy = bid, + tickerAskSell = ask0 } ) diff --git a/pub/bfx/src/Bfx/Class/ToBaseUrl.hs b/pub/bfx/src/Bfx/Class/ToBaseUrl.hs index a3d334f3..5c3aab4a 100644 --- a/pub/bfx/src/Bfx/Class/ToBaseUrl.hs +++ b/pub/bfx/src/Bfx/Class/ToBaseUrl.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Class.ToBaseUrl diff --git a/pub/bfx/src/Bfx/Class/ToPathPieces.hs b/pub/bfx/src/Bfx/Class/ToPathPieces.hs index 0cd76254..6f6821c7 100644 --- a/pub/bfx/src/Bfx/Class/ToPathPieces.hs +++ b/pub/bfx/src/Bfx/Class/ToPathPieces.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Class.ToPathPieces @@ -101,7 +100,7 @@ candlesPathPieces x = <> ":" <> toTextParam (Candles.symbol x) -instance ToPathPieces 'Tickers () where +instance ToPathPieces 'Tickers req where toPathPieces = const [ "v2", diff --git a/pub/bfx/src/Bfx/Class/ToRequestMethod.hs b/pub/bfx/src/Bfx/Class/ToRequestMethod.hs index ebe1c24a..e3ba4326 100644 --- a/pub/bfx/src/Bfx/Class/ToRequestMethod.hs +++ b/pub/bfx/src/Bfx/Class/ToRequestMethod.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Class.ToRequestMethod diff --git a/pub/bfx/src/Bfx/Class/ToRequestParam.hs b/pub/bfx/src/Bfx/Class/ToRequestParam.hs index 5b1c83dd..0bba6f4d 100644 --- a/pub/bfx/src/Bfx/Class/ToRequestParam.hs +++ b/pub/bfx/src/Bfx/Class/ToRequestParam.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Class.ToRequestParam @@ -8,7 +7,6 @@ module Bfx.Class.ToRequestParam ) where -import Bfx.Data.Metro import Bfx.Data.Web import Bfx.Import.External import qualified Data.ByteString as BS @@ -54,20 +52,17 @@ instance ToRequestParam Text where toTextParam = id --- --- TODO : need a special case only for the 'Base!!! --- -instance - ( CashTags tags, - Ratio (IntRep tags) ~ a, - HasTag (bos :: BuyOrSell) tags - ) => - ToRequestParam (Tagged tags a) - where - toTextParam amt = - case sing :: Sing bos of - SBuy -> toTextParam $ success amt - SSell -> toTextParam $ (-1) * success amt +instance ToRequestParam (BuyOrSell, MoneyAmount) where + toTextParam (bos, MoneyAmount amt) = + if bos == Sell + then toTextParam $ (-1) * rat amt + else toTextParam $ rat amt where - success :: Money tags -> Rational - success = abs . from @(Ratio Natural) @Rational . unTagged + rat = abs . from @(Ratio Natural) @Rational + +instance ToRequestParam QuotePerBase where + toTextParam = + toTextParam + . abs + . from @(Ratio Natural) @Rational + . unQuotePerBase diff --git a/pub/bfx/src/Bfx/Data/FeeSummary.hs b/pub/bfx/src/Bfx/Data/FeeSummary.hs index ab992b8f..55051e20 100644 --- a/pub/bfx/src/Bfx/Data/FeeSummary.hs +++ b/pub/bfx/src/Bfx/Data/FeeSummary.hs @@ -2,11 +2,10 @@ module Bfx.Data.FeeSummary ( Response (..), - getFee, + getCryptoFee, ) where -import Bfx.Data.Kind import Bfx.Data.Type import Bfx.Import.External @@ -14,14 +13,14 @@ import Bfx.Import.External -- TODO : this is not 100% correct -- data Response = Response - { makerCrypto2CryptoFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Maker), - makerCrypto2StableFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Maker), - makerCrypto2FiatFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Maker), - makerDerivativeRebate :: RebateRate 'Maker, - takerCrypto2CryptoFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Taker), - takerCrypto2StableFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Taker), - takerCrypto2FiatFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Taker), - takerDerivativeFee :: Money (Tags 'Unsigned |+| 'FeeRate |+| 'Taker) + { makerCrypto2CryptoFee :: FeeRate, + makerCrypto2StableFee :: FeeRate, + makerCrypto2FiatFee :: FeeRate, + makerDerivativeRebate :: RebateRate, + takerCrypto2CryptoFee :: FeeRate, + takerCrypto2StableFee :: FeeRate, + takerCrypto2FiatFee :: FeeRate, + takerDerivativeFee :: FeeRate } deriving stock ( Eq, @@ -30,21 +29,16 @@ data Response = Response Generic ) --- --- TODO : accept 2 types --- -getFee :: - forall (mot :: MakerOrTaker). - ( SingI mot - ) => +getCryptoFee :: + MakerOrTaker -> CurrencyKind -> Response -> - Money (Tags 'Unsigned |+| 'FeeRate |+| mot) -getFee ck = - case (sing :: Sing mot, ck) of - (SMaker, Crypto) -> makerCrypto2CryptoFee - (SMaker, Stable) -> makerCrypto2StableFee - (SMaker, Fiat) -> makerCrypto2FiatFee - (STaker, Crypto) -> takerCrypto2CryptoFee - (STaker, Stable) -> takerCrypto2StableFee - (STaker, Fiat) -> takerCrypto2FiatFee + FeeRate +getCryptoFee mot cck = + case (mot, cck) of + (Maker, Crypto) -> makerCrypto2CryptoFee + (Maker, Stable) -> makerCrypto2StableFee + (Maker, Fiat) -> makerCrypto2FiatFee + (Taker, Crypto) -> takerCrypto2CryptoFee + (Taker, Stable) -> takerCrypto2StableFee + (Taker, Fiat) -> takerCrypto2FiatFee diff --git a/pub/bfx/src/Bfx/Data/MarketAveragePrice.hs b/pub/bfx/src/Bfx/Data/MarketAveragePrice.hs index 2181aa9c..31208c49 100644 --- a/pub/bfx/src/Bfx/Data/MarketAveragePrice.hs +++ b/pub/bfx/src/Bfx/Data/MarketAveragePrice.hs @@ -7,13 +7,15 @@ where import Bfx.Import -data Request (bos :: BuyOrSell) = Request - { amount :: Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos), +data Request = Request + { buyOrSell :: BuyOrSell, + baseAmount :: MoneyAmount, symbol :: CurrencyPair } deriving stock ( Eq, Ord, Show, + Data, Generic ) diff --git a/pub/bfx/src/Bfx/Data/Metro.hs b/pub/bfx/src/Bfx/Data/Metro.hs deleted file mode 100644 index cb551880..00000000 --- a/pub/bfx/src/Bfx/Data/Metro.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# OPTIONS_HADDOCK show-extensions #-} - -module Bfx.Data.Metro - ( CashTags, - roundMoney, - RateTags, - roundQuotePerBase, - ) -where - -import Bfx.Import.External - -type CashTags tags = - ( MoneyTags tags, - HasTag 'Unsigned tags - ) - -roundMoney :: - forall tags m. - ( CashTags tags, - MonadThrow m - ) => - Money tags -> - m (Money tags) -roundMoney money = - if raw >= 0 && rounded >= 0 - then pure $ Tagged rounded - else throw $ TryFromException @(Ratio Natural) @(Money tags) raw Nothing - where - raw = unTagged money - rounded = - unsafeFrom @Rational @(Ratio Natural) - . roundMoneyRat - $ from @(Ratio Natural) @Rational raw - -type RateTags tags = - ( MoneyTags tags, - HasTag 'Unsigned tags, - HasTag 'QuotePerBase tags - ) - -roundQuotePerBase :: - forall tags m. - ( RateTags tags, - MonadThrow m - ) => - Money tags -> - m (Money tags) -roundQuotePerBase money = - if raw > 0 && rounded > 0 - then pure $ Tagged rounded - else throw $ TryFromException @(Ratio Natural) @(Money tags) raw Nothing - where - raw = unTagged money - rounded = - unsafeFrom @Rational @(Ratio Natural) - . roundQuotePerBaseRat - $ from @(Ratio Natural) @Rational raw - -roundMoneyRat :: Rational -> Rational -roundMoneyRat = dpRound 8 - -roundQuotePerBaseRat :: Rational -> Rational -roundQuotePerBaseRat = sdRound 5 . dpRound 8 diff --git a/pub/bfx/src/Bfx/Data/SubmitOrder.hs b/pub/bfx/src/Bfx/Data/SubmitOrder.hs index 4c7804fc..98c47e9f 100644 --- a/pub/bfx/src/Bfx/Data/SubmitOrder.hs +++ b/pub/bfx/src/Bfx/Data/SubmitOrder.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Data.SubmitOrder @@ -13,23 +12,24 @@ where import Bfx.Import import qualified Data.Aeson as A -data Request (bos :: BuyOrSell) = Request - { amount :: Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos), +data Request = Request + { buyOrSell :: BuyOrSell, + baseAmount :: MoneyAmount, symbol :: CurrencyPair, - rate :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos), - options :: Options bos + rate :: QuotePerBase, + options :: Options } - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Read, Data, Generic) -data Options (bos :: BuyOrSell) = Options - { stopLoss :: Maybe (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)), +data Options = Options + { stopLoss :: Maybe QuotePerBase, clientId :: Maybe OrderClientId, groupId :: Maybe OrderGroupId, flags :: Set OrderFlag } - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Read, Data, Generic) -optsDef :: Options bos +optsDef :: Options optsDef = Options { stopLoss = Nothing, @@ -38,7 +38,7 @@ optsDef = flags = mempty } -optsPostOnly :: Options bos +optsPostOnly :: Options optsPostOnly = Options { stopLoss = Nothing, @@ -47,9 +47,7 @@ optsPostOnly = flags = [PostOnly] } -optsPostOnlyStopLoss :: - Money (Tags 'Unsigned |+| 'QuotePerBase |+| (bos :: BuyOrSell)) -> - Options bos +optsPostOnlyStopLoss :: QuotePerBase -> Options optsPostOnlyStopLoss sl = Options { stopLoss = Just sl, @@ -58,15 +56,7 @@ optsPostOnlyStopLoss sl = flags = [PostOnly, Oco] } -instance - forall (bos :: BuyOrSell). - ( ToRequestParam (Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| bos)), - ToRequestParam (Money (Tags 'Unsigned |+| 'QuotePerBase |+| bos)), - Typeable bos, - SingI bos - ) => - ToJSON (Request bos) - where +instance ToJSON Request where toJSON req = eradicateNull . A.object @@ -77,7 +67,10 @@ instance "type" A..= ("EXCHANGE LIMIT" :: Text), "amount" - A..= toTextParam (amount req), + A..= toTextParam + ( buyOrSell req, + baseAmount req + ), "symbol" A..= toTextParam (symbol req), "price" diff --git a/pub/bfx/src/Bfx/Data/Type.hs b/pub/bfx/src/Bfx/Data/Type.hs index 73f1a1cc..bbd6a54f 100644 --- a/pub/bfx/src/Bfx/Data/Type.hs +++ b/pub/bfx/src/Bfx/Data/Type.hs @@ -7,7 +7,6 @@ module Bfx.Data.Type OrderClientId (..), OrderGroupId (..), Order (..), - SomeOrder (..), OrderFlag (..), OrderFlagAcc (..), unOrderFlag, @@ -34,13 +33,12 @@ module Bfx.Data.Type -- $misc PltStatus (..), Error (..), + emptyReq, ) where import Bfx.Class.ToRequestParam -import Bfx.Data.Kind import Bfx.Import.External -import Bfx.Orphan () import Data.Aeson (withText) import qualified Data.Aeson as A import qualified Data.Text as T @@ -111,16 +109,18 @@ newtype OrderGroupId = OrderGroupId Generic ) -data Order (act :: BuyOrSell) (loc :: LocalOrRemote) = Order +data Order = Order { orderId :: OrderId, orderGroupId :: Maybe OrderGroupId, -- | Field might be auto-generated by Bitfinex in case where -- it was not provided through 'Bfx.Data.SubmitOrder.Options'. orderClientId :: Maybe OrderClientId, - orderAmount :: Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount |+| act), + orderBaseAmount :: MoneyAmount, orderSymbol :: CurrencyPair, - orderRate :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| act), - orderStatus :: OrderStatus + orderRate :: QuotePerBase, + orderStatus :: OrderStatus, + orderBuyOrSell :: BuyOrSell, + orderLocalOrRemote :: LocalOrRemote } deriving stock ( Eq, @@ -131,24 +131,6 @@ data Order (act :: BuyOrSell) (loc :: LocalOrRemote) = Order Generic ) -data SomeOrder (loc :: LocalOrRemote) - = forall (act :: BuyOrSell). - ( Show (Order act loc), - SingI act, - Typeable act - ) => - SomeOrder - (Sing act) - (Order act loc) - -deriving stock instance Show (SomeOrder loc) - -instance Eq (SomeOrder loc) where - (SomeOrder sx x) == (SomeOrder sy y) = - case testEquality sx sy of - Just Refl -> x == y - Nothing -> False - data OrderFlag = Hidden | Close @@ -160,6 +142,7 @@ data OrderFlag ( Eq, Ord, Show, + Read, Data, Generic, Enum, @@ -172,6 +155,7 @@ newtype OrderFlagAcc ( Eq, Ord, Show, + Read, Num, ToJSON, ToJSONKey, @@ -253,166 +237,18 @@ newOrderStatus = \case -- $trading -- Data related to trading and money. --- newtype --- FeeRate --- (mrel :: MakerOrTaker) --- (crel :: CurrencyRelation) = FeeRate --- { unFeeRate :: Rational --- } --- deriving newtype --- ( Eq, --- Ord, --- Show --- ) --- deriving stock --- ( Generic, --- TH.Lift --- ) --- --- instance From (FeeRate mrel crel) Rational --- --- instance TryFrom Rational (FeeRate mrel crel) where --- tryFrom x --- | x >= 0 && x < 1 = Right $ FeeRate x --- | otherwise = Left $ TryFromException x Nothing --- --- deriving via --- Rational --- instance --- ( Typeable mrel, --- Typeable crel --- ) => --- PersistFieldSql (FeeRate mrel crel) --- --- instance --- ( Typeable mrel, --- Typeable crel --- ) => --- PersistField (FeeRate mrel crel) --- where --- toPersistValue = --- PersistRational . from --- fromPersistValue raw = --- case raw of --- PersistRational x -> --- first (const failure) $ tryFrom x --- _ -> --- Left failure --- where --- failure = --- showType @(FeeRate mrel crel) --- <> " PersistValue is invalid " --- <> show raw - -newtype RebateRate (mrel :: MakerOrTaker) - = RebateRate Rational - deriving newtype +newtype RebateRate = RebateRate + { unRebateRate :: Rational + } + deriving stock ( Eq, Ord, Show, - Num - ) - deriving stock - ( Generic + Read, + Data, + Generic ) -instance From (RebateRate mrel) Rational - -instance From Rational (RebateRate mrel) - --- newtype ProfitRate = ProfitRate --- { unProfitRate :: Rational --- } --- deriving newtype --- ( Eq, --- Ord, --- Show, --- NFData --- ) --- deriving stock --- ( Generic, --- TH.Lift --- ) --- --- instance TryFrom Rational ProfitRate where --- tryFrom x --- | x > 0 = Right $ ProfitRate x --- | otherwise = Left $ TryFromException x Nothing --- --- instance From ProfitRate Rational --- --- instance FromJSON ProfitRate where --- parseJSON = --- withText (inspectType @ProfitRate) --- $ either (fail . inspect) (pure . ProfitRate) --- . parseRatio --- --- newtype ProfitRateB (b :: MinOrMax) = ProfitRateB --- { unProfitRateB :: ProfitRate --- } --- deriving newtype --- ( Eq, --- Ord, --- Show, --- NFData, --- FromJSON --- ) --- deriving stock --- ( Generic, --- TH.Lift --- ) - --- newtype CurrencyCode (crel :: CurrencyRelation) = CurrencyCode --- { unCurrencyCode :: Text --- } --- deriving newtype --- ( Eq, --- Ord, --- Show, --- ToJSON, --- NFData --- ) --- deriving stock --- ( Generic, --- TH.Lift --- ) --- --- instance From (CurrencyCode crel0) (CurrencyCode crel1) --- --- instance (Typeable crel) => FromJSON (CurrencyCode crel) where --- parseJSON = withText --- (showType @(CurrencyCode crel)) --- $ \raw -> do --- case newCurrencyCode raw of --- Left x -> fail $ show x --- Right x -> pure x --- --- deriving via --- Text --- instance --- ( Typeable crel --- ) => --- PersistFieldSql (CurrencyCode crel) --- --- instance --- ( Typeable crel --- ) => --- PersistField (CurrencyCode crel) --- where --- toPersistValue = --- PersistText . coerce --- fromPersistValue raw = --- case raw of --- PersistText x -> --- first (const failure) $ newCurrencyCode x --- _ -> --- Left failure --- where --- failure = --- showType @(CurrencyCode crel) --- <> " PersistValue is invalid " --- <> show raw - newCurrencyCode :: (MonadThrow m) => Text -> m CurrencyCode newCurrencyCode raw = case T.strip raw of @@ -498,10 +334,8 @@ data CurrencyPairConf = CurrencyPairConf { currencyPairPrecision :: Natural, currencyPairInitMargin :: Rational, currencyPairMinMargin :: Rational, - currencyPairMaxOrderAmt :: - Money (Tags 'Unsigned |+| 'Base |+| 'Max |+| 'MoneyAmount), - currencyPairMinOrderAmt :: - Money (Tags 'Unsigned |+| 'Base |+| 'Min |+| 'MoneyAmount) + currencyPairMaxOrderBaseAmt :: MoneyAmount, + currencyPairMinOrderBaseAmt :: MoneyAmount } deriving stock ( Eq, @@ -512,11 +346,11 @@ data CurrencyPairConf = CurrencyPairConf data Candle = Candle { candleAt :: UTCTime, - candleOpen :: Money (Tags 'Unsigned |+| 'QuotePerBase), - candleClose :: Money (Tags 'Unsigned |+| 'QuotePerBase), - candleHigh :: Money (Tags 'Unsigned |+| 'QuotePerBase), - candleLow :: Money (Tags 'Unsigned |+| 'QuotePerBase), - candleVolume :: Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount) + candleOpen :: QuotePerBase, + candleClose :: QuotePerBase, + candleHigh :: QuotePerBase, + candleLow :: QuotePerBase, + candleBaseVolume :: MoneyAmount } deriving stock ( Eq, @@ -555,9 +389,9 @@ instance ToRequestParam CandleTimeFrame where data Ticker = Ticker { tickerSymbol :: CurrencyPair, - tickerVolume :: Money (Tags 'Unsigned |+| 'Base |+| 'MoneyAmount), - tickerBid :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Buy), - tickerAsk :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) + tickerBaseVolume :: MoneyAmount, + tickerBidBuy :: QuotePerBase, + tickerAskSell :: QuotePerBase } deriving stock ( Eq, @@ -587,8 +421,8 @@ data Error | ErrorMath Text | ErrorTryFrom SomeException | ErrorMissingOrder OrderId - | ErrorUnverifiedOrder (SomeOrder 'Local) (SomeOrder 'Remote) - | ErrorOrderState (SomeOrder 'Remote) + | ErrorUnverifiedOrder (Tagged 'Local Order) (Tagged 'Remote Order) + | ErrorRemoteOrderState Order | ErrorTrading CurrencyCode Text deriving stock ( Show, @@ -596,3 +430,6 @@ data Error ) instance Exception Error + +emptyReq :: Map Int Int +emptyReq = mempty diff --git a/pub/bfx/src/Bfx/Data/Wallets.hs b/pub/bfx/src/Bfx/Data/Wallets.hs index 8b90b612..515fb4ef 100644 --- a/pub/bfx/src/Bfx/Data/Wallets.hs +++ b/pub/bfx/src/Bfx/Data/Wallets.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Data.Wallets @@ -34,9 +33,9 @@ newWalletType = \case x -> Left $ TryFromException x Nothing data Response = Response - { balance :: Money (Tags 'Unsigned |+| 'MoneyAmount), - unsettledInterest :: Money (Tags 'Unsigned |+| 'MoneyAmount), - availableBalance :: Money (Tags 'Unsigned |+| 'MoneyAmount), + { balance :: MoneyAmount, + unsettledInterest :: MoneyAmount, + availableBalance :: MoneyAmount, lastChange :: Maybe Text } deriving stock diff --git a/pub/bfx/src/Bfx/Import/Internal.hs b/pub/bfx/src/Bfx/Import/Internal.hs index c4ad91fc..c6aa9c02 100644 --- a/pub/bfx/src/Bfx/Import/Internal.hs +++ b/pub/bfx/src/Bfx/Import/Internal.hs @@ -11,9 +11,8 @@ import Bfx.Class.ToRequestMethod as X import Bfx.Class.ToRequestParam as X import Bfx.Data.Env as X import Bfx.Data.Kind as X -import Bfx.Data.Metro as X import Bfx.Data.Type as X import Bfx.Data.Web as X -import Bfx.Orphan as X () +import Bfx.Math as X import Bfx.Parser as X import Bfx.Util as X diff --git a/pub/bfx/src/Bfx/Indicator/Atr.hs b/pub/bfx/src/Bfx/Indicator/Atr.hs index 3707629e..dd468899 100644 --- a/pub/bfx/src/Bfx/Indicator/Atr.hs +++ b/pub/bfx/src/Bfx/Indicator/Atr.hs @@ -14,7 +14,7 @@ import qualified Data.Vector as V import qualified Prelude newtype Atr = Atr - { unAtr :: Money (Tags 'Unsigned |+| 'QuotePerBase) + { unAtr :: QuotePerBase } deriving newtype ( Eq, @@ -83,8 +83,7 @@ unsafeAtr intPeriod xs stopAtIdx currentIdx acc = at = fst $ V.last chunk val = Atr - . Tagged + . QuotePerBase . (/ Prelude.fromIntegral intPeriod) - . unTagged - . V.foldl1 addMoney - $ V.map (Tr.unTr . snd) chunk + . V.foldl1 (+) + $ V.map (unQuotePerBase . Tr.unTr . snd) chunk diff --git a/pub/bfx/src/Bfx/Indicator/Ma.hs b/pub/bfx/src/Bfx/Indicator/Ma.hs index 40e1b69c..2c6462f4 100644 --- a/pub/bfx/src/Bfx/Indicator/Ma.hs +++ b/pub/bfx/src/Bfx/Indicator/Ma.hs @@ -13,7 +13,7 @@ import qualified Data.Vector as V import qualified Prelude newtype Ma = Ma - { unMa :: Money (Tags 'Unsigned |+| 'QuotePerBase) + { unMa :: QuotePerBase } deriving stock ( Eq, @@ -72,8 +72,7 @@ unsafeMa maPeriod candles stopAtIdx currentIdx acc = maUtc = candleAt $ V.last chunk maVal = Ma - . Tagged + . QuotePerBase . (/ Prelude.fromIntegral maPeriod) - . unTagged - . V.foldl1 addMoney - $ V.map candleClose chunk + . V.foldl1 (+) + $ V.map (unQuotePerBase . candleClose) chunk diff --git a/pub/bfx/src/Bfx/Indicator/Tr.hs b/pub/bfx/src/Bfx/Indicator/Tr.hs index f985af8e..b7fb1916 100644 --- a/pub/bfx/src/Bfx/Indicator/Tr.hs +++ b/pub/bfx/src/Bfx/Indicator/Tr.hs @@ -10,7 +10,7 @@ import Bfx.Import import qualified Data.Vector as V newtype Tr = Tr - { unTr :: Money (Tags 'Unsigned |+| 'QuotePerBase) + { unTr :: QuotePerBase } deriving stock ( Eq, @@ -37,13 +37,10 @@ tr cs = ) <$> zip (toList cs) (tail cs) -absRange :: - Money (Tags 'Unsigned |+| 'QuotePerBase) -> - Money (Tags 'Unsigned |+| 'QuotePerBase) -> - Money (Tags 'Unsigned |+| 'QuotePerBase) +absRange :: QuotePerBase -> QuotePerBase -> QuotePerBase absRange x y = - Tagged + QuotePerBase . unsafeFrom @Rational @(Ratio Natural) . abs - $ abs (from @(Ratio Natural) @Rational $ unTagged x) - - abs (from @(Ratio Natural) @Rational $ unTagged y) + $ abs (from @(Ratio Natural) @Rational $ unQuotePerBase x) + - abs (from @(Ratio Natural) @Rational $ unQuotePerBase y) diff --git a/pub/bfx/src/Bfx/Math.hs b/pub/bfx/src/Bfx/Math.hs index 600bd82b..6becda6e 100644 --- a/pub/bfx/src/Bfx/Math.hs +++ b/pub/bfx/src/Bfx/Math.hs @@ -1,181 +1,182 @@ {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Math - ( tweakMoneyPip, - tweakMakerRate, + ( tweakMoneyAmount, + tweakQuotePerBase, newCounterOrder, - -- newCounterOrderSimple, + CounterArgs (..), + CounterRates (..), + CounterExit (..), + roundMoneyAmount, + roundQuotePerBase, ) where -import Bfx.Data.Kind -import Bfx.Data.Metro import Bfx.Import.External -tweakMoneyPip :: - forall tags bos m. - ( CashTags tags, - HasTag 'Base tags, - HasTag (bos :: BuyOrSell) tags, - MonadThrow m +tweakMoneyAmount :: + ( MonadThrow m ) => - Money tags -> - m (Money tags) -tweakMoneyPip amt = - case sing :: Sing bos of - SBuy -> tweakMoneyPip' (`addMoney` pip) amt - SSell -> tweakMoneyPip' (`deductMoney` pip) amt - where - pip :: Money tags - pip = Tagged 0.00000001 + BuyOrSell -> + MoneyAmount -> + m MoneyAmount +tweakMoneyAmount = + tweakMoneyAmountRec pip -tweakMoneyPip' :: - ( CashTags tags, - HasTag 'Base tags, - MonadThrow m +tweakMoneyAmountRec :: + ( MonadThrow m ) => - (Money tags -> Money tags) -> - Money tags -> - m (Money tags) -tweakMoneyPip' expr amt = do - newAmt <- roundMoney $ expr amt - if newAmt /= amt - then pure newAmt - else tweakMoneyPip' (expr . expr) amt + Ratio Natural -> + BuyOrSell -> + MoneyAmount -> + m MoneyAmount +tweakMoneyAmountRec tweak bos prev = do + next <- + roundMoneyAmount + . MoneyAmount + $ case bos of + Buy -> unMoneyAmount prev + tweak + Sell -> unMoneyAmount prev - tweak + if next /= prev + then pure next + else tweakMoneyAmountRec (tweak + pip) bos prev -tweakMakerRate :: - forall tags bos m. - ( RateTags tags, - HasTag (bos :: BuyOrSell) tags, - MonadThrow m +tweakQuotePerBase :: + ( MonadThrow m ) => - Money tags -> - m (Money tags) -tweakMakerRate rate = - tweakMakerRateRec rate rate tweak - where - -- - -- TODO : ??? use pip when 'units' bug with - -- arithmetic underflow will be fixed. - -- This implementation is wrong for - -- non-negative types: - -- - -- (|-|) :: (d1 @~ d2, Num n) => Qu d1 l n -> Qu d2 l n -> Qu d1 l n - -- a |-| b = a |+| qNegate b - -- - tweak :: Ratio Natural - tweak = - case sing :: Sing bos of - SBuy -> 999 % 1000 - SSell -> 1001 % 1000 + BuyOrSell -> + QuotePerBase -> + m QuotePerBase +tweakQuotePerBase = + tweakQuotePerBaseRec pip -tweakMakerRateRec :: - forall tags m. - ( RateTags tags, - MonadThrow m +tweakQuotePerBaseRec :: + ( MonadThrow m ) => - Money tags -> - Money tags -> Ratio Natural -> - m (Money tags) -tweakMakerRateRec rate prev tweak = - case roundQuotePerBase next of - Left e -> throw e - Right x | x /= rate -> pure x - Right {} -> tweakMakerRateRec rate next tweak - where - next = Tagged @tags $ unTagged @tags prev * tweak + BuyOrSell -> + QuotePerBase -> + m QuotePerBase +tweakQuotePerBaseRec tweak bos prev = do + next <- roundQuotePerBase + . QuotePerBase + $ case bos of + Buy -> unQuotePerBase prev - tweak + Sell -> unQuotePerBase prev + tweak + if next /= prev + then pure next + else tweakQuotePerBaseRec (tweak + pip) bos prev -newCounterOrder :: - ( MonadThrow m - ) => - Money (Tags 'Unsigned |+| 'Base |+| 'Buy |+| 'Gross |+| 'MoneyAmount) -> - Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Buy |+| 'Net) -> - Money (Tags 'Unsigned |+| 'Base |+| 'FeeRate) -> - Money (Tags 'Unsigned |+| 'Quote |+| 'FeeRate) -> - Money (Tags 'Unsigned |+| 'Quote |+| 'Buy |+| 'Net |+| 'ProfitRate) -> - m - ( Money - ( Tags 'Unsigned - |+| 'Quote - |+| 'Sell - |+| 'Gross - |+| 'Revenue - |+| 'MoneyAmount - ), - Money - ( Tags 'Unsigned - |+| 'Base - |+| 'Sell - |+| 'Net - |+| 'MoneyAmount - ), - Money - ( Tags 'Unsigned - |+| 'QuotePerBase - |+| 'Sell - ) +pip :: Ratio Natural +pip = 0.00000001 + +data CounterArgs = CounterArgs + { counterArgsEnterGrossBaseGain :: MoneyAmount, + counterArgsEnterQuotePerBase :: QuotePerBase, + counterArgsRates :: CounterRates + } + deriving stock + ( Eq, + Ord, + Show, + Read, + Data, + Generic ) -newCounterOrder enterBaseGain enterRate enterFee exitFee profRate = do - exitQuote <- roundMoney exitQuoteGain - exitBase <- - tweakMoneyPip - =<< roundMoney exitBaseLoss + +data CounterRates = CounterRates + { counterRatesEnterBaseFee :: FeeRate, + counterRatesExitQuoteFee :: FeeRate, + counterRatesExitQuoteProfit :: ProfitRate + } + deriving stock + ( Eq, + Ord, + Show, + Read, + Data, + Generic + ) + +data CounterExit = CounterExit + { counterExitNetBaseLoss :: MoneyAmount, + counterExitQuotePerBase :: QuotePerBase + } + deriving stock + ( Eq, + Ord, + Show, + Read, + Data, + Generic + ) + +newCounterOrder :: (MonadThrow m) => CounterArgs -> m CounterExit +newCounterOrder args = do + exitBase <- tweakMoneyAmount Sell exitBaseLoss exitPrice <- roundQuotePerBase exitRate - pure (exitQuote, exitBase, exitPrice) + pure + CounterExit + { counterExitNetBaseLoss = exitBase, + counterExitQuotePerBase = exitPrice + } where - exitBaseLoss :: - Money (Tags 'Unsigned |+| 'Base |+| 'Sell |+| 'Net |+| 'MoneyAmount) + enterBaseGain :: MoneyAmount + enterBaseGain = + counterArgsEnterGrossBaseGain args + enterRate :: QuotePerBase + enterRate = + counterArgsEnterQuotePerBase args + enterFee :: FeeRate + enterFee = + counterRatesEnterBaseFee $ counterArgsRates args + exitFee :: FeeRate + exitFee = + counterRatesExitQuoteFee $ counterArgsRates args + profRate :: ProfitRate + profRate = + counterRatesExitQuoteProfit $ counterArgsRates args + exitBaseLoss :: MoneyAmount exitBaseLoss = - deductFee enterFee - $ reTag @'Buy @'Sell enterBaseGain - enterQuoteLoss :: - Money (Tags 'Unsigned |+| 'Quote |+| 'Buy |+| 'Net |+| 'MoneyAmount) + MoneyAmount $ unMoneyAmount enterBaseGain * (1 - unFeeRate enterFee) + enterQuoteLoss :: MoneyAmount enterQuoteLoss = - exchangeMoney @(Tags 'Unsigned |+| 'Buy |+| 'Net) enterRate - $ reTag @'Gross @'Net enterBaseGain - exitQuoteGain :: - Money - ( Tags 'Unsigned - |+| 'Quote - |+| 'Sell - |+| 'Gross - |+| 'Revenue - |+| 'MoneyAmount - ) + MoneyAmount $ unMoneyAmount enterBaseGain * unQuotePerBase enterRate + exitQuoteGain :: MoneyAmount exitQuoteGain = - addFee - exitFee - . reTag @'Buy @'Sell - $ addProfit - @(Tags 'Unsigned |+| 'Quote |+| 'Buy |+| 'Net) - profRate - enterQuoteLoss - exitRate :: Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) + MoneyAmount + $ (unMoneyAmount enterQuoteLoss * (1 + unProfitRate profRate)) + / (1 - unFeeRate exitFee) + exitRate :: QuotePerBase exitRate = - newQuotePerBase @(Tags 'Unsigned |+| 'Sell |+| 'MoneyAmount) - (unTag @'Gross $ unTag @'Revenue exitQuoteGain) - (unTag @'Net exitBaseLoss) + QuotePerBase + $ unMoneyAmount exitQuoteGain + / unMoneyAmount exitBaseLoss + +roundMoneyAmount :: (MonadThrow m) => MoneyAmount -> m MoneyAmount +roundMoneyAmount arg@(MoneyAmount raw) = + if raw >= 0 && rounded >= 0 + then pure $ MoneyAmount rounded + else throwString $ "Rounding error for " <> inspect @String arg + where + rounded = + unsafeFrom @Rational @(Ratio Natural) + . roundMoneyAmountRat + $ from @(Ratio Natural) @Rational raw + +roundQuotePerBase :: (MonadThrow m) => QuotePerBase -> m QuotePerBase +roundQuotePerBase arg@(QuotePerBase raw) = + if raw > 0 && rounded > 0 + then pure $ QuotePerBase rounded + else throwString $ "Rounding error for " <> inspect @String arg + where + rounded = + unsafeFrom @Rational @(Ratio Natural) + . roundQuotePerBaseRat + $ from @(Ratio Natural) @Rational raw + +roundMoneyAmountRat :: Rational -> Rational +roundMoneyAmountRat = dpRound 8 --- newCounterOrderSimple :: --- ( MonadThrow m --- ) => --- Money (Tags 'Unsigned |+| 'Base |+| 'Sell) -> --- Money (Tags 'Unsigned |+| 'QuotePerBase |+| 'Sell) -> --- Money (Tags 'Unsigned |+| 'FeeRate |+| 'Quote) -> --- m (Money (Tags 'Unsigned |+| 'Quote |+| 'Sell)) --- newCounterOrderSimple base rate fee = --- tryErrorE $ roundMoney' exitQuoteGain --- where --- exitFee :: Rational --- exitFee = --- from fee --- exitRate :: Money (Tags 'Unsigned |+| 'QuotePerBase) --- exitRate = --- unQuotePerBase rate --- exitBaseLoss :: Money (Tags 'Unsigned |+| 'Base |+| 'Sell) --- exitBaseLoss = --- unTagged base --- exitQuoteGain :: Money (Tags 'Unsigned |+| 'Quote |+| 'Net) --- exitQuoteGain = --- (exitBaseLoss |*| exitRate) |* (1 - exitFee) +roundQuotePerBaseRat :: Rational -> Rational +roundQuotePerBaseRat = sdRound 5 . dpRound 8 diff --git a/pub/bfx/src/Bfx/Orphan.hs b/pub/bfx/src/Bfx/Orphan.hs deleted file mode 100644 index bc391f67..00000000 --- a/pub/bfx/src/Bfx/Orphan.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Bfx.Orphan () where - -import Bfx.Data.Kind -import Bfx.Import.External - -mkFgpt @Method - -deriving newtype instance HasCodec CurrencyCode - -deriving newtype instance HasItemCodec CurrencyCode diff --git a/pub/bfx/src/Bfx/Parser.hs b/pub/bfx/src/Bfx/Parser.hs index ede272c6..293c437e 100644 --- a/pub/bfx/src/Bfx/Parser.hs +++ b/pub/bfx/src/Bfx/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Parser @@ -8,20 +7,15 @@ module Bfx.Parser ) where -import Bfx.Data.Metro import Bfx.Data.Type import Bfx.Import.External +import Bfx.Math import Data.Aeson.Lens import qualified Data.Map as Map import qualified Prelude parseOrder :: - ( AsValue a, - Show a, - Data a - ) => - a -> - Either Text (SomeOrder 'Remote) + (Show a, Data a, AsValue a) => a -> Either Text Order parseOrder x = do id0 <- maybeToRight (failure "OrderId is missing") @@ -60,12 +54,10 @@ parseOrder x = do <$> x ^? nth 7 . _Number - -- - -- TODO : handle zero amt??? - -- - -- SomeMoney bos amt <- - -- first (failure . ("OrderAmount is invalid " <>) . inspect) - -- $ tryFrom amt0 + let amt = + MoneyAmount + . unsafeFrom @Rational @(Ratio Natural) + $ abs amt0 ss0 <- maybeToRight (failure "OrderStatus is missing") $ x @@ -81,47 +73,34 @@ parseOrder x = do ^? nth 16 . _Number rate <- - first (const . failure $ "ExchangeRate is invalid " <> inspect price) + bimap + (const . failure $ "ExchangeRate is invalid " <> inspect price) + QuotePerBase $ tryFrom @Rational @(Ratio Natural) (toRational price) - case newUnsignedMoneyBOS @(Tags 'Base |+| 'MoneyAmount) amt0 of - SomeMoney bos amt -> - pure - . SomeOrder bos - $ Order + let mkOrder bos = + Order { orderId = id0, orderGroupId = gid, orderClientId = cid, - orderAmount = amt, + orderBaseAmount = amt, orderSymbol = sym, - orderRate = Tagged rate, - orderStatus = ss1 + orderRate = rate, + orderStatus = ss1, + orderBuyOrSell = bos, + orderLocalOrRemote = Remote } + if + | amt0 > 0 -> pure $ mkOrder Buy + | amt0 < 0 -> pure $ mkOrder Sell + | otherwise -> Left "Got zero money amount" where - -- let SomeMoney bos amt = - -- newUnsignedMoneyBOS @(Tags 'Base) amt0 :: - -- SomeMoney BuyOrSell (Tags 'Unsigned |+| 'Base) - -- case bos of - -- SBuy -> - -- pure - -- . SomeOrder SBuy - -- $ Order - -- { orderId = id0, - -- orderGroupId = gid, - -- orderClientId = cid, - -- orderAmount = amt, - -- orderSymbol = sym, - -- orderRate = Tagged rate, - -- orderStatus = ss1 - -- } - - failure = - (<> " in " <> inspect x) + failure = (<> " in " <> inspect x) parseOrderMap :: ( AsValue a ) => a -> - Either Text (Map OrderId (SomeOrder 'Remote)) + Either Text (Map OrderId Order) parseOrderMap raw = do xs <- maybeToRight @@ -131,8 +110,8 @@ parseOrderMap raw = do foldrM parser mempty xs where parser x acc = do - someOrder@(SomeOrder _ order) <- parseOrder x - pure $ Map.insert (orderId order) someOrder acc + order <- parseOrder x + pure $ Map.insert (orderId order) order acc parseCandle :: ( AsValue a @@ -151,7 +130,7 @@ parseCandle x = do open <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase -- -- TODO : tryFrom??? -- @@ -162,7 +141,7 @@ parseCandle x = do close <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase -- -- TODO : tryFrom??? -- @@ -173,7 +152,7 @@ parseCandle x = do high <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase -- -- TODO : tryFrom??? -- @@ -184,7 +163,7 @@ parseCandle x = do low <- first inspect . roundQuotePerBase - . Tagged + . QuotePerBase -- -- TODO : tryFrom??? -- @@ -194,8 +173,8 @@ parseCandle x = do (toRational <$> x ^? nth 4 . _Number) vol <- first inspect - . roundMoney - . Tagged + . roundMoneyAmount + . MoneyAmount -- -- TODO : tryFrom??? -- @@ -210,5 +189,5 @@ parseCandle x = do candleClose = close, candleHigh = high, candleLow = low, - candleVolume = vol + candleBaseVolume = vol } diff --git a/pub/bfx/src/Bfx/Rpc/Generic.hs b/pub/bfx/src/Bfx/Rpc/Generic.hs index de33f5fc..2903ccd8 100644 --- a/pub/bfx/src/Bfx/Rpc/Generic.hs +++ b/pub/bfx/src/Bfx/Rpc/Generic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Rpc.Generic diff --git a/pub/bfx/src/Bfx/Util.hs b/pub/bfx/src/Bfx/Util.hs index 58744b6c..abda0646 100644 --- a/pub/bfx/src/Bfx/Util.hs +++ b/pub/bfx/src/Bfx/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Util diff --git a/pub/bfx/test/Bfx/Data/CancelOrderMultiSpec.hs b/pub/bfx/test/Bfx/Data/CancelOrderMultiSpec.hs index 6c270eaa..20a5db8e 100644 --- a/pub/bfx/test/Bfx/Data/CancelOrderMultiSpec.hs +++ b/pub/bfx/test/Bfx/Data/CancelOrderMultiSpec.hs @@ -13,20 +13,20 @@ import Test.Hspec spec :: Spec spec = describe "ToJSON" $ do - it "ByOrderId" $ - A.encode (ByOrderId [OrderId 1, OrderId 23]) - `shouldBe` "{\"id\":[1,23]}" - it "ByOrderClientId" $ - A.encode + it "ByOrderId" + $ A.encode (ByOrderId [OrderId 1, OrderId 23]) + `shouldBe` "{\"id\":[1,23]}" + it "ByOrderClientId" + $ A.encode ( ByOrderClientId [ (OrderClientId 1, epoch), (OrderClientId 23, addUTCTime 86400 epoch) ] ) - `shouldBe` "{\"cid\":[[1,\"1970-01-01\"],[23,\"1970-01-02\"]]}" - it "ByOrderGroupId" $ - A.encode (ByOrderGroupId [OrderGroupId 1, OrderGroupId 23]) - `shouldBe` "{\"gid\":[1,23]}" - it "Everything" $ - A.encode Everything - `shouldBe` "{\"all\":1}" + `shouldBe` "{\"cid\":[[1,\"1970-01-01\"],[23,\"1970-01-02\"]]}" + it "ByOrderGroupId" + $ A.encode (ByOrderGroupId [OrderGroupId 1, OrderGroupId 23]) + `shouldBe` "{\"gid\":[1,23]}" + it "Everything" + $ A.encode Everything + `shouldBe` "{\"all\":1}" diff --git a/pub/bfx/test/Bfx/Data/SubmitOrderSpec.hs b/pub/bfx/test/Bfx/Data/SubmitOrderSpec.hs index 910718eb..3db0f5da 100644 --- a/pub/bfx/test/Bfx/Data/SubmitOrderSpec.hs +++ b/pub/bfx/test/Bfx/Data/SubmitOrderSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Data.SubmitOrderSpec @@ -16,12 +15,12 @@ spec :: Spec spec = before sysEnv $ describe "ToJSON" $ do it "Request" . const $ do - adabtc <- newCurrencyPair "ADABTC" let req = SubmitOrder.Request - (testAmt @'Buy) - adabtc - (Tagged 0.00081037) + Buy + testAdaAmt + adaBtc + (QuotePerBase 0.00081037) SubmitOrder.optsPostOnly A.encode req `shouldBe` "{\"amount\":\"4.004004\",\"flags\":4096,\"price\":\"0.00081037\",\"symbol\":\"tADABTC\",\"type\":\"EXCHANGE LIMIT\"}" diff --git a/pub/bfx/test/Bfx/Data/TypeSpec.hs b/pub/bfx/test/Bfx/Data/TypeSpec.hs index f98f2706..25a95e51 100644 --- a/pub/bfx/test/Bfx/Data/TypeSpec.hs +++ b/pub/bfx/test/Bfx/Data/TypeSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.Data.TypeSpec diff --git a/pub/bfx/test/Bfx/MathSpec.hs b/pub/bfx/test/Bfx/MathSpec.hs new file mode 100644 index 00000000..06cda29b --- /dev/null +++ b/pub/bfx/test/Bfx/MathSpec.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +module Bfx.MathSpec + ( spec, + ) +where + +import Bfx.Import +import Test.Hspec + +spec :: Spec +spec = + it "newCounterOrder" $ do + let rates = + CounterRates + { counterRatesEnterBaseFee = FeeRate 0.001, + counterRatesExitQuoteFee = FeeRate 0.001, + counterRatesExitQuoteProfit = ProfitRate 0.01 + } + let args = + CounterArgs + { counterArgsEnterGrossBaseGain = MoneyAmount 0.2, + counterArgsEnterQuotePerBase = QuotePerBase 5, + counterArgsRates = rates + } + exit <- newCounterOrder args + exit + `shouldBe` CounterExit + { -- Deduct fee and pip: + -- 0.2 * 0.999 - 0.00000001 + counterExitNetBaseLoss = MoneyAmount 0.19979999, + -- Add profit and fee: + -- ((0.2 * 5) * (1 + 0.01) / (1 - 0.001)) / 0.19979999 + counterExitQuotePerBase = QuotePerBase 5.0601 + } diff --git a/pub/bfx/test/Bfx/TestEnv.hs b/pub/bfx/test/Bfx/TestEnv.hs index 7a7c3c60..ea28091c 100644 --- a/pub/bfx/test/Bfx/TestEnv.hs +++ b/pub/bfx/test/Bfx/TestEnv.hs @@ -1,47 +1,22 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module Bfx.TestEnv - ( eraseFirst, - testAmt, - itRight, - itLeft, + ( adaBtc, + btcAda, + testAdaAmt, ) where import Bfx.Import -import qualified Test.Hspec as HS -eraseFirst :: (Bifunctor f) => f a b -> f () b -eraseFirst = - first $ const () +adaBtc :: CurrencyPair +adaBtc = + either impureThrow id $ newCurrencyPair "ADABTC" -testAmt :: - forall act. - ( CashTags (Tags 'MoneyAmount |+| 'Unsigned |+| 'Base |+| act) - ) => - Money (Tags 'MoneyAmount |+| 'Unsigned |+| 'Base |+| act) -testAmt = - Tagged 4.004004 +btcAda :: CurrencyPair +btcAda = + either impureThrow id $ newCurrencyPair "BTCADA" -itRight :: - ( Show a - ) => - String -> - (Env -> ExceptT Error IO a) -> - HS.SpecWith (HS.Arg (Env -> IO ())) -itRight label test = - HS.it label $ \env -> do - x <- runExceptT $ test env - x `HS.shouldSatisfy` isRight - -itLeft :: - ( Show a - ) => - String -> - (Env -> ExceptT Error IO a) -> - HS.SpecWith (HS.Arg (Env -> IO ())) -itLeft label test = - HS.it label $ \env -> do - x <- runExceptT $ test env - x `HS.shouldSatisfy` isLeft +testAdaAmt :: MoneyAmount +testAdaAmt = + MoneyAmount 4.004004 diff --git a/pub/bfx/test/BfxSpec.hs b/pub/bfx/test/BfxSpec.hs index d8cbbbf4..f704d658 100644 --- a/pub/bfx/test/BfxSpec.hs +++ b/pub/bfx/test/BfxSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_HADDOCK show-extensions #-} module BfxSpec @@ -6,12 +5,10 @@ module BfxSpec ) where -import qualified Bfx as Bitfinex --- import qualified Bfx.Chart as Chart --- import qualified Bfx.Data.CancelOrderMulti as CancelOrderMulti - +import qualified Bfx import qualified Bfx.Data.Candles as Candles import qualified Bfx.Data.GetOrders as GetOrders +import qualified Bfx.Data.MarketAveragePrice as MarketAveragePrice import qualified Bfx.Data.SubmitOrder as SubmitOrder import Bfx.Import import Bfx.TestEnv @@ -20,92 +17,124 @@ import Test.Hspec spec :: Spec spec = before sysEnv $ do - let adabtc = either impureThrow id $ newCurrencyPair "ADABTC" it "platformStatus succeeds" . const $ do - ss <- Bitfinex.platformStatus + ss <- Bfx.platformStatus ss `shouldBe` PltOperative it "symbolsDetails succeeds" . const $ do - ss <- Bitfinex.symbolsDetails - Map.lookup adabtc ss + ss <- Bfx.symbolsDetails + Map.lookup adaBtc ss `shouldBe` Just CurrencyPairConf { currencyPairPrecision = 5, currencyPairInitMargin = 30 % 1, currencyPairMinMargin = 15, - currencyPairMaxOrderAmt = Tagged 250000, - currencyPairMinOrderAmt = Tagged 4 + currencyPairMaxOrderBaseAmt = MoneyAmount 250000, + currencyPairMinOrderBaseAmt = MoneyAmount 4 } it "marketAveragePrice succeeds" . const $ do - sym <- newCurrencyPair "ADABTC" - buyRate <- Bitfinex.marketAveragePrice (testAmt @'Buy) sym - sellRate <- Bitfinex.marketAveragePrice (testAmt @'Sell) sym - unTagged buyRate `shouldSatisfy` (> unTagged sellRate) + buyRate <- + Bfx.marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Buy, + MarketAveragePrice.baseAmount = testAdaAmt, + MarketAveragePrice.symbol = adaBtc + } + sellRate <- + Bfx.marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Sell, + MarketAveragePrice.baseAmount = testAdaAmt, + MarketAveragePrice.symbol = adaBtc + } + buyRate `shouldSatisfy` (> sellRate) it "marketAveragePrice fails" . const $ do - let amt = testAmt @'Buy - sym <- newCurrencyPair "BTCADA" - res <- tryAny $ Bitfinex.marketAveragePrice amt sym + res <- + tryAny + $ Bfx.marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Sell, + MarketAveragePrice.baseAmount = testAdaAmt, + MarketAveragePrice.symbol = btcAda + } res `shouldSatisfy` isLeft it "feeSummary succeeds" $ \env -> do - res <- tryAny $ Bitfinex.feeSummary env + res <- tryAny $ Bfx.feeSummary env res `shouldSatisfy` isRight it "submitOrderMaker and cancelOrderById succeeds" $ \env -> do - let amt = testAmt @'Buy - let opts = SubmitOrder.optsPostOnly - sym <- newCurrencyPair "ADABTC" - curRate <- Bitfinex.marketAveragePrice amt sym - rate <- (* 0.5) <$> roundQuotePerBase curRate - order <- Bitfinex.submitOrderMaker env amt sym rate opts - res <- tryAny . Bitfinex.cancelOrderById env $ orderId order + curRate <- + Bfx.marketAveragePrice + MarketAveragePrice.Request + { MarketAveragePrice.buyOrSell = Buy, + MarketAveragePrice.baseAmount = testAdaAmt, + MarketAveragePrice.symbol = adaBtc + } + rate <- + roundQuotePerBase + . QuotePerBase + . (* 0.5) + $ unQuotePerBase curRate + order <- + Bfx.submitOrderMaker + env + SubmitOrder.Request + { SubmitOrder.buyOrSell = Buy, + SubmitOrder.baseAmount = testAdaAmt, + SubmitOrder.symbol = adaBtc, + SubmitOrder.rate = rate, + SubmitOrder.options = SubmitOrder.optsPostOnly + } + res <- + tryAny + . Bfx.cancelOrderById env + $ orderId order res `shouldSatisfy` isRight it "retrieveOrders succeeds" $ \env -> do - res <- tryAny . Bitfinex.retrieveOrders env $ GetOrders.optsSym adabtc + res <- tryAny . Bfx.retrieveOrders env $ GetOrders.optsSym adaBtc res `shouldSatisfy` isRight it "ordersHistory succeeds" $ \env -> do - res <- tryAny . Bitfinex.ordersHistory env $ GetOrders.optsSym adabtc + res <- tryAny . Bfx.ordersHistory env $ GetOrders.optsSym adaBtc res `shouldSatisfy` isRight it "getOrders succeeds" $ \env -> do - res <- tryAny . Bitfinex.getOrders env $ GetOrders.optsSym adabtc + res <- tryAny . Bfx.getOrders env $ GetOrders.optsSym adaBtc res `shouldSatisfy` isRight it "getOrder fails" $ \env -> do - res <- tryAny . Bitfinex.getOrder env $ OrderId 0 + res <- tryAny . Bfx.getOrder env $ OrderId 0 res `shouldSatisfy` isLeft it "submitCounterOrderMaker fails" $ \env -> do res <- tryAny - $ Bitfinex.submitCounterOrderMaker + $ Bfx.submitCounterOrderMaker env (OrderId 0) - (Tagged 0.001) - (Tagged 0.001) - (Tagged 0.001) + CounterRates + { counterRatesEnterBaseFee = FeeRate 0, + counterRatesExitQuoteFee = FeeRate 0, + counterRatesExitQuoteProfit = ProfitRate 0 + } SubmitOrder.optsPostOnly res `shouldSatisfy` isLeft it "wallets succeeds" $ \env -> do - res <- tryAny $ Bitfinex.wallets env + res <- tryAny $ Bfx.wallets env res `shouldSatisfy` isRight it "netWorth succeeds" $ \env -> do - res <- tryAny . Bitfinex.netWorth env $ CurrencyCode "BTC" + res <- tryAny . Bfx.netWorth env $ CurrencyCode "BTC" res `shouldSatisfy` isRight it "candlesLast succeeds" . const $ do - res <- tryAny $ Bitfinex.candlesLast Ctf1h adabtc Candles.optsDef + res <- tryAny $ Bfx.candlesLast Ctf1h adaBtc Candles.optsDef res `shouldSatisfy` isRight it "candlesHist succeeds" . const $ do - res <- tryAny $ Bitfinex.candlesHist Ctf1h adabtc Candles.optsDef + res <- tryAny $ Bfx.candlesHist Ctf1h adaBtc Candles.optsDef res `shouldSatisfy` isRight --- it "chart" . const $ do --- Chart.newExample --- True `shouldBe` True - -- describe "End2End" $ do -- itRight "submitOrderMaker" $ \env -> do -- let amt = from @(Ratio Natural) 2.002002 :: Money 'Base 'Buy -- let sym = [currencyPair|ADABTC|] -- let opts = SubmitOrder.optsPostOnly --- rate <- Bitfinex.marketAveragePrice amt sym --- Bitfinex.submitOrderMaker env amt sym rate opts +-- rate <- Bfx.marketAveragePrice amt sym +-- Bfx.submitOrderMaker env amt sym rate opts -- itRight "submitCounterOrderMaker" $ \env -> --- Bitfinex.submitCounterOrderMaker +-- Bfx.submitCounterOrderMaker -- env -- (OrderId 0) -- [feeRateMakerBase| 0.001 |] @@ -113,11 +142,11 @@ spec = before sysEnv $ do -- [profitRate| 0.001 |] -- SubmitOrder.optsPostOnly -- focus . itRight "cancelOrderMulti" $ \env -> --- Bitfinex.cancelOrderMulti +-- Bfx.cancelOrderMulti -- env -- CancelOrderMulti.Everything -- focus . itRight "dumpIntoQuoteMaker" $ \env -> --- Bitfinex.dumpIntoQuoteMaker +-- Bfx.dumpIntoQuoteMaker -- env -- [currencyPair|XLM:BTC|] -- SubmitOrder.optsPostOnly diff --git a/pub/functora/src/cfg/Functora/CfgOrphan.hs b/pub/functora/src/cfg/Functora/CfgOrphan.hs index 77ea476f..0f3c7cf7 100644 --- a/pub/functora/src/cfg/Functora/CfgOrphan.hs +++ b/pub/functora/src/cfg/Functora/CfgOrphan.hs @@ -142,6 +142,35 @@ instance (Toml.HasCodec a) => Toml.HasCodec (Tagged t a) where hasCodec = Toml.diwrap . Toml.hasCodec @a +instance (Toml.HasItemCodec a) => Toml.HasItemCodec (Tagged t a) where + hasItemCodec = + bimap Toml._Coerce Toml.diwrap $ Toml.hasItemCodec @a + +_Ratio :: + forall a. + ( Integral a, + From a Integer, + TryFrom Integer a + ) => + Toml.TomlBiMap (Ratio a) Toml.AnyValue +_Ratio = + Toml.mkAnyValueBiMap + ( \src -> do + let failure = + Toml.MatchError Toml.TDouble + $ Toml.AnyValue src + dbl <- + Toml.matchDouble src + rat <- + first (const failure) + $ tryFrom @Double @Rational dbl + first (const failure) + $ tryFrom @Rational @(Ratio a) rat + ) + ( Toml.Double + . via @Rational @(Ratio a) @Double + ) + -- -- TODO : how to make an instance for a Rational nicely? -- @@ -152,24 +181,16 @@ instance ) => Toml.HasCodec (Ratio a) where - hasCodec = - Toml.match - $ Toml.mkAnyValueBiMap - ( \src -> do - let failure = - Toml.MatchError Toml.TDouble - $ Toml.AnyValue src - dbl <- - Toml.matchDouble src - rat <- - first (const failure) - $ tryFrom @Double @Rational dbl - first (const failure) - $ tryFrom @Rational @(Ratio a) rat - ) - ( Toml.Double - . via @Rational @(Ratio a) @Double - ) + hasCodec = Toml.match $ _Ratio @a + +instance + ( Integral a, + From a Integer, + TryFrom Integer a + ) => + Toml.HasItemCodec (Ratio a) + where + hasItemCodec = Left $ _Ratio @a {-# INLINE defaultPutList #-} defaultPutList :: (Binary a) => [a] -> Binary.Put diff --git a/pub/functora/src/money/Functora/Money.hs b/pub/functora/src/money/Functora/Money.hs index 3d053cf4..da639ee1 100644 --- a/pub/functora/src/money/Functora/Money.hs +++ b/pub/functora/src/money/Functora/Money.hs @@ -2,34 +2,17 @@ module Functora.Money ( module X, - IntRep, - MoneyTags, - NewMoneyTags, - Money, - parseMoney, - addMoney, - deductMoney, - SomeMoney (..), - newUnsignedMoneyBOS, - newUnsignedMoneyGOL, - newFeeRate, - newProfitRate, - addFee, - deductFee, - addProfit, - exchangeMoney, - newQuotePerBase, - Funds (..), - fundsMoneyAmount, - fundsCurrencyCode, - unJsonRational, - unJsonMoney, - unJsonUnsignedMoneyBOS, - unJsonUnsignedMoneyGOL, + Money (..), + MoneyAmount (..), + QuotePerBase (..), CurrencyCode (..), inspectCurrencyCode, CurrencyInfo (..), inspectCurrencyInfo, + FeeRate (..), + ProfitRate (..), + unJsonRational, + unJsonRatio, ) where @@ -39,286 +22,74 @@ import Functora.MoneySing as X import Functora.Prelude import Functora.Tags as X -type IntRep tags = IntRepFamily (GetTag SignedOrUnsigned tags) - -type family IntRepFamily tag where - IntRepFamily 'Signed = Integer - IntRepFamily 'Unsigned = Natural - -type RatTags tags = - ( Eq (IntRep tags), - Ord (IntRep tags), - Show (IntRep tags), - Read (IntRep tags), - Data (IntRep tags), - Integral (IntRep tags), - From (IntRep tags) Integer, - Typeable (IntRep tags), - Typeable tags - ) - -type NewRatTags lhs rhs = - ( lhs ~ rhs, - RatTags lhs - ) - -type Money tags = - Tagged - tags - ( Ratio - ( IntRep - ( RefineTags tags '[SignedOrUnsigned, MoneyKind] - ) - ) +data Money = Money + { moneyAmount :: MoneyAmount, + moneyCurrencyCode :: CurrencyCode + } + deriving stock (Eq, Ord, Show, Read, Data, Generic) + deriving + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec ) + via GenericType Money -type MoneyTags tags = - ( RatTags tags, - tags ~ RefineTags tags '[SignedOrUnsigned, MoneyKind] - ) - -type NewMoneyTags lhs rhs = - ( NewRatTags lhs rhs, - MoneyTags lhs - ) - -parseMoney :: - forall str tags m. - ( From str Text, - Show str, - Data str, - MoneyTags tags, - MonadThrow m - ) => - str -> - m (Money tags) -parseMoney = - fmap Tagged . parseRatio - -addMoney :: (MoneyTags tags) => Money tags -> Money tags -> Money tags -addMoney lhs rhs = - (+) <$> lhs <*> rhs - -deductMoney :: (MoneyTags tags) => Money tags -> Money tags -> Money tags -deductMoney lhs rhs = - (-) <$> lhs <*> rhs - -data SomeMoney k tags - = forall (tag :: k). - ( SingI tag, - Typeable tag, - Typeable k, - MoneyTags (tags |+| tag) - ) => - SomeMoney - (Sing tag) - (Money (tags |+| tag)) - -instance (TestEquality (Sing :: k -> Type)) => Eq (SomeMoney k tags) where - (SomeMoney sx x) == (SomeMoney sy y) = - case testEquality sx sy of - Just Refl -> x == y - Nothing -> False - -deriving stock instance Show (SomeMoney k tags) - -newUnsignedMoneyBOS :: - forall tags buy sell. - ( NewMoneyTags buy (tags |+| 'Unsigned |+| 'Buy), - NewMoneyTags sell (tags |+| 'Unsigned |+| 'Sell), - IntRep buy ~ Natural, - IntRep sell ~ Natural - ) => - Rational -> - SomeMoney BuyOrSell (tags |+| 'Unsigned) -newUnsignedMoneyBOS raw - | raw < 0 = SomeMoney (sing :: Sing 'Sell) (Tagged uns :: Money sell) - | otherwise = SomeMoney (sing :: Sing 'Buy) (Tagged uns :: Money buy) - where - uns = unsafeFrom @Rational @(Ratio Natural) $ abs raw - -newUnsignedMoneyGOL :: - forall tags gain lose. - ( NewMoneyTags gain (tags |+| 'Unsigned |+| 'Gain), - NewMoneyTags lose (tags |+| 'Unsigned |+| 'Lose), - IntRep gain ~ Natural, - IntRep lose ~ Natural - ) => - Rational -> - SomeMoney GainOrLose (tags |+| 'Unsigned) -newUnsignedMoneyGOL raw - | raw < 0 = SomeMoney (sing :: Sing 'Lose) (Tagged uns :: Money lose) - | otherwise = SomeMoney (sing :: Sing 'Gain) (Tagged uns :: Money gain) - where - uns = unsafeFrom @Rational @(Ratio Natural) $ abs raw - -newFeeRate :: - forall tags. - ( MoneyTags (tags |+| 'FeeRate) - ) => - Ratio (IntRep (tags |+| 'FeeRate)) -> - Money (tags |+| 'FeeRate) -newFeeRate = Tagged - -newProfitRate :: - forall tags. - ( MoneyTags (tags |+| 'ProfitRate) - ) => - Ratio (IntRep (tags |+| 'ProfitRate)) -> - Money (tags |+| 'ProfitRate) -newProfitRate = Tagged - -addFee :: - forall fee amt tags. - ( IntRep fee ~ IntRep amt, - IntRep fee ~ IntRep tags, - MoneyTags fee, - MoneyTags amt, - NewMoneyTags tags (amt |-| 'Net |+| 'Gross) - ) => - Money fee -> - Money amt -> - Money tags -addFee (Tagged fee) (Tagged amt) = - Tagged $ amt / (1 - fee) - -deductFee :: - forall fee amt tags. - ( IntRep fee ~ IntRep amt, - IntRep fee ~ IntRep tags, - MoneyTags fee, - MoneyTags amt, - NewMoneyTags tags (amt |-| 'Gross |+| 'Net) - ) => - Money fee -> - Money amt -> - Money tags -deductFee (Tagged fee) (Tagged amt) = - Tagged $ amt * (1 - fee) - -addProfit :: - forall tags. - ( IntRep (tags |+| 'MoneyAmount) ~ IntRep (tags |+| 'ProfitRate), - IntRep (tags |+| 'MoneyAmount) ~ IntRep (tags |+| 'MoneyAmount |+| 'Revenue), - MoneyTags (tags |+| 'ProfitRate), - MoneyTags (tags |+| 'MoneyAmount), - MoneyTags (tags |+| 'MoneyAmount |+| 'Revenue) - ) => - Money (tags |+| 'ProfitRate) -> - Money (tags |+| 'MoneyAmount) -> - Money (tags |+| 'MoneyAmount |+| 'Revenue) -addProfit (Tagged rate) (Tagged amt) = - Tagged $ amt * (1 + rate) - -exchangeMoney :: - forall tags. - ( IntRep (tags |+| 'QuotePerBase) ~ IntRep (tags |+| 'Base |+| 'MoneyAmount), - IntRep (tags |+| 'QuotePerBase) ~ IntRep (tags |+| 'Quote |+| 'MoneyAmount), - MoneyTags (tags |+| 'QuotePerBase), - MoneyTags (tags |+| 'Base |+| 'MoneyAmount), - MoneyTags (tags |+| 'Quote |+| 'MoneyAmount) - ) => - Money (tags |+| 'QuotePerBase) -> - Money (tags |+| 'Base |+| 'MoneyAmount) -> - Money (tags |+| 'Quote |+| 'MoneyAmount) -exchangeMoney (Tagged rate) (Tagged base) = - Tagged $ rate * base - -newQuotePerBase :: - forall tags. - ( IntRep (tags |+| 'Quote) ~ IntRep (tags |+| 'Base), - IntRep (tags |+| 'Quote) ~ IntRep (tags |-| 'MoneyAmount |+| 'QuotePerBase), - MoneyTags (tags |+| 'Quote), - MoneyTags (tags |+| 'Base), - MoneyTags (tags |-| 'MoneyAmount |+| 'QuotePerBase) - ) => - Money (tags |+| 'Quote) -> - Money (tags |+| 'Base) -> - Money (tags |-| 'MoneyAmount |+| 'QuotePerBase) -newQuotePerBase (Tagged quote) (Tagged base) = - Tagged $ quote / base - -data Funds tags where - Funds :: - forall tags. - ( MoneyTags tags - ) => - Money tags -> - CurrencyCode -> - Funds tags - -fundsMoneyAmount :: Funds tags -> Money tags -fundsMoneyAmount (Funds amt _) = amt - -fundsCurrencyCode :: Funds tags -> CurrencyCode -fundsCurrencyCode (Funds _ cur) = cur - -deriving stock instance Eq (Funds tags) - -deriving stock instance Ord (Funds tags) - -deriving stock instance (MoneyTags tags) => Show (Funds tags) - -deriving stock instance (MoneyTags tags) => Read (Funds tags) - -deriving stock instance (MoneyTags tags) => Data (Funds tags) - -unJsonRational :: A.Decoder Rational -unJsonRational = toRational <$> A.scientific - -unJsonMoney :: - forall tags (tag :: SignedOrUnsigned). - ( MoneyTags tags, - HasTag tag tags - ) => - A.Decoder (Money tags) -unJsonMoney = do - rat <- unJsonRational - case sing :: Sing tag of - SSigned -> pure $ Tagged rat - SUnsigned -> - either (fail . inspect) (pure . Tagged) - $ tryFrom @Rational @(Ratio Natural) rat - -unJsonUnsignedMoneyBOS :: - forall tags buy sell. - ( NewMoneyTags buy (tags |+| 'Unsigned |+| 'Buy), - NewMoneyTags sell (tags |+| 'Unsigned |+| 'Sell), - IntRep buy ~ Natural, - IntRep sell ~ Natural - ) => - A.Decoder (SomeMoney BuyOrSell (tags |+| 'Unsigned)) -unJsonUnsignedMoneyBOS = - newUnsignedMoneyBOS @tags <$> unJsonRational +newtype MoneyAmount = MoneyAmount + { unMoneyAmount :: Ratio Natural + } + deriving stock (Eq, Ord, Show, Read, Data, Generic) + deriving newtype + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec + ) -unJsonUnsignedMoneyGOL :: - forall tags gain lose. - ( NewMoneyTags gain (tags |+| 'Unsigned |+| 'Gain), - NewMoneyTags lose (tags |+| 'Unsigned |+| 'Lose), - IntRep gain ~ Natural, - IntRep lose ~ Natural - ) => - A.Decoder (SomeMoney GainOrLose (tags |+| 'Unsigned)) -unJsonUnsignedMoneyGOL = - newUnsignedMoneyGOL @tags <$> unJsonRational +newtype QuotePerBase = QuotePerBase + { unQuotePerBase :: Ratio Natural + } + deriving stock (Eq, Ord, Show, Read, Data, Generic) + deriving newtype + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec + ) newtype CurrencyCode = CurrencyCode { unCurrencyCode :: Unicode } deriving stock (Eq, Ord, Show, Read, Data, Generic) - deriving newtype (Binary, FromJSON, FromJSONKey, ToJSON, ToJSONKey) + deriving newtype + ( Binary, + ToJSON, + ToJSONKey, + FromJSON, + FromJSONKey, + HasCodec, + HasItemCodec + ) inspectCurrencyCode :: CurrencyCode -> Unicode -inspectCurrencyCode = - strip - . unCurrencyCode +inspectCurrencyCode = strip . unCurrencyCode data CurrencyInfo = CurrencyInfo { currencyInfoCode :: CurrencyCode, currencyInfoText :: Unicode } deriving stock (Eq, Ord, Show, Read, Data, Generic) - deriving (Binary, FromJSON, ToJSON) via GenericType CurrencyInfo + deriving + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec + ) + via GenericType CurrencyInfo inspectCurrencyInfo :: CurrencyInfo -> Unicode inspectCurrencyInfo input = @@ -329,8 +100,41 @@ inspectCurrencyInfo input = info = strip $ currencyInfoText input code = inspectCurrencyCode $ currencyInfoCode input --- --- TODO : remove it --- --- example :: Money (Tags 'Unsigned) --- example = Tagged 1 +newtype FeeRate = FeeRate + { unFeeRate :: Ratio Natural + } + deriving stock (Eq, Ord, Show, Read, Data, Generic) + deriving newtype + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec + ) + +newtype ProfitRate = ProfitRate + { unProfitRate :: Ratio Natural + } + deriving stock (Eq, Ord, Show, Read, Data, Generic) + deriving newtype + ( Binary, + ToJSON, + FromJSON, + HasCodec, + HasItemCodec + ) + +unJsonRational :: A.Decoder Rational +unJsonRational = toRational <$> A.scientific + +unJsonRatio :: + forall a. + ( Data a, + Integral a, + TryFrom Integer a + ) => + A.Decoder (Ratio a) +unJsonRatio = do + rat <- unJsonRational + either (fail . inspect) pure + $ tryFrom @Rational @(Ratio a) rat diff --git a/pub/functora/src/money/Functora/MoneySing.hs b/pub/functora/src/money/Functora/MoneySing.hs index d9508ae4..dc510a07 100644 --- a/pub/functora/src/money/Functora/MoneySing.hs +++ b/pub/functora/src/money/Functora/MoneySing.hs @@ -7,9 +7,6 @@ import Functora.Tags import qualified Language.Haskell.TH.Syntax as TH import Prelude -data MoneyKind = MoneyAmount | Currency | QuotePerBase | FeeRate | ProfitRate - deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic, TH.Lift) - data CurrencyKind = Crypto | Stable | Fiat deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic, TH.Lift) @@ -40,8 +37,6 @@ data Revenue = Revenue data SignedOrUnsigned = Signed | Unsigned deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Data, Generic, TH.Lift) -type instance Fgpt MoneyKind = "Functora.MoneySing.MoneyKind" - type instance Fgpt CurrencyKind = "Functora.MoneySing.CurrencyKind" type instance Fgpt BuyOrSell = "Functora.MoneySing.BuyOrSell" @@ -158,48 +153,6 @@ instance TestEquality (Sing :: BaseOrQuote -> Type) where testEquality SQuote SQuote = Just Refl testEquality _ _ = Nothing --- --- MoneyKind --- - -data instance Sing (x :: MoneyKind) where - SMoneyAmount :: Sing 'MoneyAmount - SCurrency :: Sing 'Currency - SQuotePerBase :: Sing 'QuotePerBase - SFeeRate :: Sing 'FeeRate - SProfitRate :: Sing 'ProfitRate - -instance SingKind MoneyKind where - type Demote MoneyKind = MoneyKind - fromSing SMoneyAmount = MoneyAmount - fromSing SCurrency = Currency - fromSing SQuotePerBase = QuotePerBase - fromSing SFeeRate = FeeRate - fromSing SProfitRate = ProfitRate - toSing MoneyAmount = SomeSing SMoneyAmount - toSing Currency = SomeSing SCurrency - toSing QuotePerBase = SomeSing SQuotePerBase - toSing FeeRate = SomeSing SFeeRate - toSing ProfitRate = SomeSing SProfitRate - -instance SingI 'MoneyAmount where sing = SMoneyAmount - -instance SingI 'Currency where sing = SCurrency - -instance SingI 'QuotePerBase where sing = SQuotePerBase - -instance SingI 'FeeRate where sing = SFeeRate - -instance SingI 'ProfitRate where sing = SProfitRate - -instance TestEquality (Sing :: MoneyKind -> Type) where - testEquality SMoneyAmount SMoneyAmount = Just Refl - testEquality SCurrency SCurrency = Just Refl - testEquality SQuotePerBase SQuotePerBase = Just Refl - testEquality SFeeRate SFeeRate = Just Refl - testEquality SProfitRate SProfitRate = Just Refl - testEquality _ _ = Nothing - -- -- MakerOrTaker -- diff --git a/pub/functora/src/rates/Functora/Rates.hs b/pub/functora/src/rates/Functora/Rates.hs index b0805904..ea8ae7ea 100644 --- a/pub/functora/src/rates/Functora/Rates.hs +++ b/pub/functora/src/rates/Functora/Rates.hs @@ -88,7 +88,7 @@ withNewMarket opts expr = do -- Stateful data QuoteAt = QuoteAt - { quoteMoneyAmount :: Money (Tags 'Signed |+| 'Quote |+| 'MoneyAmount), + { quoteMoneyAmount :: MoneyAmount, quoteCreatedAt :: UTCTime, quoteUpdatedAt :: UTCTime } @@ -100,11 +100,11 @@ getQuote :: MonadUnliftIO m ) => Opts -> - Funds (Tags 'Signed |+| 'Base |+| 'MoneyAmount) -> + Money -> CurrencyCode -> ReaderT (MVar Market) m QuoteAt -getQuote opts baseFunds quoteCurrency = do - let baseCurrency = fundsCurrencyCode baseFunds +getQuote opts baseMoney quoteCurrency = do + let baseCurrency = moneyCurrencyCode baseMoney quotes <- getQuotesPerBase opts baseCurrency case Map.lookup quoteCurrency $ quotesPerBaseQuotesMap quotes of Nothing -> @@ -114,8 +114,9 @@ getQuote opts baseFunds quoteCurrency = do pure QuoteAt { quoteMoneyAmount = - exchangeMoney @(Tags 'Signed) quotesPerBase - $ fundsMoneyAmount baseFunds, + MoneyAmount + $ (quotesPerBase ^. #unQuotePerBase) + * (baseMoney ^. #moneyAmount . #unMoneyAmount), quoteCreatedAt = quotesPerBaseCreatedAt quotes, quoteUpdatedAt = quotesPerBaseUpdatedAt quotes } @@ -230,8 +231,7 @@ tryFetchCurrencies opts uri = tryMarket $ do pure Currencies {currenciesList = xs2, currenciesUpdatedAt = ct} data QuotesPerBaseAt = QuotesPerBaseAt - { quotesPerBaseQuotesMap :: - Map CurrencyCode (Money (Tags 'Signed |+| 'QuotePerBase)), + { quotesPerBaseQuotesMap :: Map CurrencyCode QuotePerBase, quotesPerBaseCreatedAt :: UTCTime, quotesPerBaseUpdatedAt :: UTCTime } @@ -269,7 +269,8 @@ tryFetchQuotesPerBase opts cur uri = tryMarket $ do . from @Unicode @Text $ unCurrencyCode cur ] - $ A.mapStrict unJsonMoney + . A.mapStrict + $ fmap QuotePerBase unJsonRatio pure QuotesPerBaseAt { quotesPerBaseQuotesMap = diff --git a/pub/functora/src/test/Functora/RatesSpec.hs b/pub/functora/src/test/Functora/RatesSpec.hs index f4e739ef..4b39ddd7 100644 --- a/pub/functora/src/test/Functora/RatesSpec.hs +++ b/pub/functora/src/test/Functora/RatesSpec.hs @@ -63,9 +63,9 @@ spec = do tryMarket $ getQuote defOpts - ( Funds - (Tagged 1) - (CurrencyCode "btc") - ) + Money + { moneyAmount = MoneyAmount 1, + moneyCurrencyCode = CurrencyCode "btc" + } quoteCurrency lift $ res `shouldSatisfy` isRight