From c26c5dfe6a39811bea662bef087ac31d36ba231d Mon Sep 17 00:00:00 2001 From: hsloan Date: Wed, 7 Jul 2021 19:46:53 +0000 Subject: [PATCH 1/3] refactor swap dashboard to show transaction details on right side of swap form --- use-case-2/frontend/src/Frontend.hs | 112 +++++++++++++++------------- 1 file changed, 60 insertions(+), 52 deletions(-) diff --git a/use-case-2/frontend/src/Frontend.hs b/use-case-2/frontend/src/Frontend.hs index e86ab4df7..8995c1cde 100644 --- a/use-case-2/frontend/src/Frontend.hs +++ b/use-case-2/frontend/src/Frontend.hs @@ -27,7 +27,6 @@ import qualified Data.HashMap.Lazy as HMap import Data.Semigroup (First(..)) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Read as T import qualified Data.Vector as V import Data.Vessel import Data.Vessel.Identity @@ -166,12 +165,14 @@ swapDashboard wid = Workflow $ do requesting_ $ (Api_CallPools (ContractInstanceId wid)) <$ (leftmost [pb, () <$ pollingEvent]) let portfolioEv = flip ffilter navEvent $ \navEv -> navEv == Dashboard_Portfolio poolEv = flip ffilter navEvent $ \navEv -> navEv == Dashboard_Pool - _ <- divClass "p-5 mb-4 bg-light rounded-5" $ do - divClass "container-fluid py-5" $ do - elClass "h3" "display-5 fw-bold" $ text "Swap Tokens" + _ <- divClass "container" $ do + divClass "pricing-header px-3 py-3 pt-md-5 pb-md-4 mx-auto text-center" $ do + elClass "h1" "display-5 fw-bold" $ text "Swap Tokens" el "p" $ text "What would you like to swap?" + -- widget that contains the swap form + divClass "card-group mb-3 text-center" $ do dmmPooledTokens <- viewPooledTokens - _ <- switchHold never <=< dyn $ ffor dmmPooledTokens $ \case + formEvent <- switchHold never <=< dyn $ ffor dmmPooledTokens $ \case Nothing -> return never Just mPoolTokens -> case mPoolTokens of Nothing -> return never @@ -184,32 +185,33 @@ swapDashboard wid = Workflow $ do elClass "p" "text-warning" $ text "There are no tokens available to swap." return never Just fstOpt -> do - divClass "form container" $ do - divClass "form-group" $ do - -- Select first token and amount + divClass "col" $ divClass "card mb-4 box-shadow h-100 mx-3" $ do + divClass "card-header" $ elClass "h4" "my-0 font-weight-normal" $ text "Select Coins" + divClass "card-body" $ divClass "form container" $ divClass "form-group" $ do -- TODO: Create a convenient widget function out of the dropdown text input for coins + -- Select first token and amount (selectionA, amountA) <- divClass "input-group row" $ do coinAChoice <- dropdown fstOpt (constDyn $ dropdownList) $ - def { _dropdownConfig_attributes = constDyn ("class" =: "form-control col-md-1") } + def { _dropdownConfig_attributes = constDyn ("class" =: "form-control") } coinAAmountInput <- inputElement $ def & inputElementConfig_elementConfig . elementConfig_initialAttributes - .~ ("class" =: "form-control col-md-4" <> "type" =: "number") + .~ ("class" =: "form-control" <> "type" =: "number") & inputElementConfig_initialValue .~ ("0" :: Text) return (_dropdown_value coinAChoice, _inputElement_value coinAAmountInput) -- Select second token and amount (selectionB, amountB) <- divClass "input-group row mt-3" $ do coinBChoice <- dropdown fstOpt (constDyn $ dropdownList) $ - def { _dropdownConfig_attributes = constDyn ("class" =: "form-control col-md-1") } + def { _dropdownConfig_attributes = constDyn ("class" =: "form-control") } coinBAmountInput <- inputElement $ def & inputElementConfig_elementConfig . elementConfig_initialAttributes - .~ ("class" =: "form-control col-md-4" <> "type" =: "number") + .~ ("class" =: "form-control" <> "type" =: "number") & inputElementConfig_initialValue .~ ("0" :: Text) return (_dropdown_value coinBChoice, _inputElement_value coinBAmountInput) -- TODO: add loading modal swap <- divClass "input-group row mt-3" $ do - (e,_) <- elClass' "button" "btn btn-primary" $ text "Swap" + (e,_) <- elClass' "button" "btn btn-lg btn-block btn-outline-primary" $ text "Swap" return $ domEvent Click e let pooledTokenToCoin pt = Coin $ AssetClass (CurrencySymbol (_pooledToken_symbol pt), TokenName (_pooledToken_name pt)) toAmount amt = Amount $ (read (T.unpack amt) :: Integer) @@ -221,10 +223,11 @@ swapDashboard wid = Workflow $ do <*> (toAmount <$> amountB)) -- This response doesn't return anything useful, so it is thrown away _ <- requesting $ tagPromptlyDyn requestLoad swap - _ <- fmap (switch . current) $ prerender (return never) $ do + fmap (switch . current) $ prerender (return never) $ do ws <- jsonWebSocket ("ws://localhost:8080/ws/" <> wid) (def :: WebSocketConfig t Aeson.Value) -- TODO: Create abstracted function for filtering out websocket events - let observableStateSuccessEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value ) + let ffor4 a b c d f = liftA3 f a b c <*> d + observableStateSuccessEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value ) -> case mIncomingWebSocketData of Nothing -> False Just incomingWebSocketData -> do @@ -238,39 +241,6 @@ swapDashboard wid = Workflow $ do let newObservableStateTag = incomingWebSocketData ^.. key "tag" . _String failureMessageTag = incomingWebSocketData ^.. key "contents" . key "Left" . _String newObservableStateTag == ["NewObservableState"] && failureMessageTag /= [""] - -- Pools is used to get information about liquidity pools and token pairs to provide swap estimations - poolsEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value) -> case mIncomingWebSocketData of - Nothing -> False - Just incomingWebSocketData -> do - let observableStateTag = incomingWebSocketData ^.. key "tag" . _String - poolsTag = incomingWebSocketData ^.. key "contents" . key "Right" . key "tag" . _String - observableStateTag == ["NewObservableState"] && poolsTag == ["Pools"] - dynPoolMap <- holdDyn Map.empty $ ffor poolsEvent $ \mIncomingPoolsWebSocketData -> do - let poolDetails = case mIncomingPoolsWebSocketData of - Nothing -> V.empty - Just poolsWebSocketData -> poolsWebSocketData ^. key "contents" . key "Right" . key "contents" . _Array - parseLiquidityTokensToMap poolDetails - -- Determine what amount will be received after - let swapInput = ffor2 amountA amountB $ \a b -> (a,b) - ffor4 a b c d f = liftA3 f a b c <*> d - swapEstimate = ffor4 selectionA selectionB swapInput dynPoolMap $ \selA selB (amtA, amtB) poolMap -> do - let ((coinAName, coinAPoolAmount), (coinBName, coinBPoolAmount)) = fromMaybe (("", 0), ("", 0)) - $ fmap snd - $ headMay - $ Map.elems - $ Map.filter (\(_,((tknameA,_), (tknameB, _))) - -> tknameA == (_pooledToken_name selA) && tknameB == (_pooledToken_name selB)) poolMap - (amtA',_) :: (Integer, Text) <- T.decimal amtA - (amtB',_) :: (Integer, Text) <- T.decimal amtB - let (swapAmount, estimatedTkName) = if amtA' == 0 then (amtB',coinAName) else (amtA',coinBName) - return $ (findSwapA coinAPoolAmount coinBPoolAmount swapAmount, estimatedTkName) - -- display estimated funds to be received during swap and the token name to be received - divClass "p-3 mt-2" $ widgetHold_ blank $ ffor (updated swapEstimate) $ \case - Left err -> elClass "p" "text-danger" $ text $ T.pack $ show err - Right (estimate, eTokenName) -> elClass "p" "text-info" $ text - $ "In this transaction you will receive " - <> (T.pack $ show estimate) - <> " " <> (T.pack $ show $ if "" == eTokenName then "ADA" else eTokenName) -- this event will cause the success message to disappear when it occurs vanishEvent <- delay 7 observableStateSuccessEvent -- show success message based on new observable state @@ -284,10 +254,48 @@ swapDashboard wid = Workflow $ do Just incomingWebSocketData -> do let errMsg = incomingWebSocketData ^.. key "contents" . key "Left" . _String elClass "p" "text-danger" $ text $ T.concat errMsg - return never - return () - return never - return () + return $ updated $ fmap Just $ ffor4 selectionA amountA selectionB amountB $ \selA amtA selB amtB -> ((selA, amtA), (selB, amtB)) + -- widget that shows transaction details such as swap estimates, etc. + divClass "col" $ divClass "card mb-4 box-shadow h-100" $ do + divClass "card-header" $ elClass "h4" "my-0 font-weight-normal" $ text "Transaction Details" + divClass "card-body" $ do + poolMapEv <- fmap (switch . current) $ prerender (return never) $ do + ws <- jsonWebSocket ("ws://localhost:8080/ws/" <> wid) (def :: WebSocketConfig t Aeson.Value) + -- TODO: Create abstracted function for filtering out websocket events + -- Pools is used to get information about liquidity pools and token pairs to provide swap estimations + let poolsEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value) -> case mIncomingWebSocketData of + Nothing -> False + Just incomingWebSocketData -> do + let observableStateTag = incomingWebSocketData ^.. key "tag" . _String + poolsTag = incomingWebSocketData ^.. key "contents" . key "Right" . key "tag" . _String + observableStateTag == ["NewObservableState"] && poolsTag == ["Pools"] + dynPoolMap <- holdDyn Map.empty $ ffor poolsEvent $ \mIncomingPoolsWebSocketData -> do + let poolDetails = case mIncomingPoolsWebSocketData of + Nothing -> V.empty + Just poolsWebSocketData -> poolsWebSocketData ^. key "contents" . key "Right" . key "contents" . _Array + parseLiquidityTokensToMap poolDetails + return $ fmap Just $ updated dynPoolMap + -- combine events from from updates and smart contract pool data to perform swap estimates + dynPoolMap <- holdDyn Nothing poolMapEv + poolAndFormEvent <- holdDyn (Nothing, Nothing) $ attachPromptlyDyn dynPoolMap formEvent + let swapEstimate = ffor poolAndFormEvent $ \case + (Just poolMap, Just ((selA, amtA), (selB, amtB))) -> do + let ((coinAName, coinAPoolAmount), (coinBName, coinBPoolAmount)) = fromMaybe (("", 0), ("", 0)) + $ fmap snd + $ headMay + $ Map.elems + $ Map.filter (\(_,((tknameA,_), (tknameB, _))) + -> tknameA == (_pooledToken_name selA) && tknameB == (_pooledToken_name selB)) poolMap + let amtA' :: Integer = fromMaybe 0 $ readMay $ T.unpack amtA + amtB' :: Integer = fromMaybe 0 $ readMay $ T.unpack amtB + (swapAmount, estimatedTkName) = if amtA' == 0 then (amtB',coinAName) else (amtA',coinBName) + (findSwapA coinAPoolAmount coinBPoolAmount swapAmount, estimatedTkName) + _ -> (0, "") + widgetHold_ blank $ ffor (updated swapEstimate) $ \(estimate, eTokenName) -> + elClass "p" "text-info" $ text + $ "Estimated to receive " + <> (T.pack $ show estimate) + <> " " <> (T.pack $ show $ if "" == eTokenName then "ADA" else eTokenName) return ((), leftmost [(portfolioDashboard wid) <$ portfolioEv, poolDashboard wid <$ poolEv]) portfolioDashboard :: forall t m js. (MonadRhyoliteWidget (DexV (Const SelectedCount)) Api t m, Prerender js t m, MonadIO (Performable m)) From 8375ed64c2002df765ac2eb520f0dd88bf2d0c26 Mon Sep 17 00:00:00 2001 From: hsloan Date: Wed, 7 Jul 2021 20:06:13 +0000 Subject: [PATCH 2/3] move websocket parsing functions to their own module --- use-case-2/frontend/frontend.cabal | 1 + use-case-2/frontend/src/Frontend.hs | 39 +-------------- .../frontend/src/Frontend/WebsocketParse.hs | 50 +++++++++++++++++++ 3 files changed, 53 insertions(+), 37 deletions(-) create mode 100644 use-case-2/frontend/src/Frontend/WebsocketParse.hs diff --git a/use-case-2/frontend/frontend.cabal b/use-case-2/frontend/frontend.cabal index 112844a66..bfa702751 100644 --- a/use-case-2/frontend/frontend.cabal +++ b/use-case-2/frontend/frontend.cabal @@ -28,6 +28,7 @@ library , vessel exposed-modules: Frontend + Frontend.WebsocketParse ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wincomplete-record-updates -O -fno-show-valid-hole-fits executable frontend diff --git a/use-case-2/frontend/src/Frontend.hs b/use-case-2/frontend/src/Frontend.hs index 8995c1cde..d12ebf094 100644 --- a/use-case-2/frontend/src/Frontend.hs +++ b/use-case-2/frontend/src/Frontend.hs @@ -21,9 +21,8 @@ import Control.Monad import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson import Data.Aeson.Lens -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import qualified Data.HashMap.Lazy as HMap import Data.Semigroup (First(..)) import Data.Text (Text) import qualified Data.Text as T @@ -45,6 +44,7 @@ import Common.Route import Common.Plutus.Contracts.Uniswap.Types import Common.Plutus.Contracts.Uniswap.Estimates import Common.Schema +import Frontend.WebsocketParse -- This runs in a monad that can be run on the client or the server. @@ -624,41 +624,6 @@ poolDashboard wid = Workflow $ do return () return ((), leftmost [swapDashboard wid <$ swapEv, portfolioDashboard wid <$ portfolioEv]) --- TODO: Create a websocket parsing module for this -parseTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, Text) -parseTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case - Aeson.Array xs -> case V.toList xs of - symbol:(Aeson.Array tokens):_ -> - let currencySymbol = symbol ^. key "unCurrencySymbol" . _String - tokens' = ffor tokens $ \case - Aeson.Array xs' -> case V.toList xs' of - tokenName:tokenAmount:_ -> Just - ( tokenName ^. key "unTokenName" . _String - , (fromMaybe 0 $ tokenAmount ^? _Integer, currencySymbol) - ) - _ -> Nothing - _ -> Nothing - in Just $ Map.fromList $ catMaybes $ V.toList tokens' - _ -> Nothing - _ -> Just Map.empty - --- returns Map of TokenName (LiquidityAmount, ((CoinA, CoinAPoolAmount), (CoinB, CoinBPoolAmount))) -parseLiquidityTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, ((Text,Integer), (Text, Integer))) -parseLiquidityTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case - Aeson.Array xs -> case V.toList xs of - coinA:coinB:(Aeson.Array liquidityCoin):_-> case V.toList liquidityCoin of - (Aeson.Object obj):(Aeson.Number lqAmount):_ -> case HMap.toList obj of - (_, Aeson.String lqTokenName):_ -> do - let tna = coinA ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String - tnaPool = fromMaybe 0 $ coinA ^? nth 1 . _Integer - tnb = coinB ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String - tnbPool = fromMaybe 0 $ coinB ^? nth 1 . _Integer - Just $ Map.singleton lqTokenName ((fromMaybe 0 $ lqAmount ^? _Integer), ((tna, tnaPool),(tnb, tnbPool))) - _ -> Nothing - _ -> Nothing - _ -> Nothing - _ -> Just Map.empty - viewContracts :: (MonadQuery t (Vessel Q (Const SelectedCount)) m, Reflex t) => m (Dynamic t (Maybe (Maybe [Text]))) viewContracts = (fmap.fmap.fmap) (getFirst . runIdentity) $ queryViewMorphism 1 $ constDyn $ vessel Q_ContractList . identityV diff --git a/use-case-2/frontend/src/Frontend/WebsocketParse.hs b/use-case-2/frontend/src/Frontend/WebsocketParse.hs new file mode 100644 index 000000000..26322df07 --- /dev/null +++ b/use-case-2/frontend/src/Frontend/WebsocketParse.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Frontend.WebsocketParse where + +import Control.Lens +import qualified Data.Aeson as Aeson +import Data.Aeson.Lens +import qualified Data.HashMap.Lazy as HMap +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, catMaybes) +import Data.Text (Text) +import qualified Data.Vector as V +import Reflex.Dom.Core + +-- TODO: Create a websocket parsing module for this +parseTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, Text) +parseTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case + Aeson.Array xs -> case V.toList xs of + symbol:(Aeson.Array tokens):_ -> + let currencySymbol = symbol ^. key "unCurrencySymbol" . _String + tokens' = ffor tokens $ \case + Aeson.Array xs' -> case V.toList xs' of + tokenName:tokenAmount:_ -> Just + ( tokenName ^. key "unTokenName" . _String + , (fromMaybe 0 $ tokenAmount ^? _Integer, currencySymbol) + ) + _ -> Nothing + _ -> Nothing + in Just $ Map.fromList $ catMaybes $ V.toList tokens' + _ -> Nothing + _ -> Just Map.empty + +-- returns Map of TokenName (LiquidityAmount, ((CoinA, CoinAPoolAmount), (CoinB, CoinBPoolAmount))) +parseLiquidityTokensToMap :: V.Vector Aeson.Value -> Map.Map Text (Integer, ((Text,Integer), (Text, Integer))) +parseLiquidityTokensToMap cd = mconcat $ catMaybes $ V.toList $ ffor cd $ \case + Aeson.Array xs -> case V.toList xs of + coinA:coinB:(Aeson.Array liquidityCoin):_-> case V.toList liquidityCoin of + (Aeson.Object obj):(Aeson.Number lqAmount):_ -> case HMap.toList obj of + (_, Aeson.String lqTokenName):_ -> do + let tna = coinA ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String + tnaPool = fromMaybe 0 $ coinA ^? nth 1 . _Integer + tnb = coinB ^. nth 0 . key "unAssetClass" . values . key "unTokenName" . _String + tnbPool = fromMaybe 0 $ coinB ^? nth 1 . _Integer + Just $ Map.singleton lqTokenName ((fromMaybe 0 $ lqAmount ^? _Integer), ((tna, tnaPool),(tnb, tnbPool))) + _ -> Nothing + _ -> Nothing + _ -> Nothing + _ -> Just Map.empty + From 976e0965b15254d0cc36946be3e1aeec2cb3691a Mon Sep 17 00:00:00 2001 From: hsloan Date: Wed, 7 Jul 2021 22:17:12 +0000 Subject: [PATCH 3/3] add ability to view estimated liquidity amount before staking --- .../Plutus/Contracts/Uniswap/Estimates.hs | 70 +++++++++++++++++-- use-case-2/frontend/src/Frontend.hs | 29 ++++++++ 2 files changed, 94 insertions(+), 5 deletions(-) diff --git a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs index 9bf92a0a3..2ae315e19 100644 --- a/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs +++ b/use-case-2/common/src/Common/Plutus/Contracts/Uniswap/Estimates.hs @@ -6,16 +6,20 @@ - This modules is full of functions used to provide estimates for swaps, liquidity redemption, etc. -} +{-# LANGUAGE DerivingStrategies #-} + module Common.Plutus.Contracts.Uniswap.Estimates where +import Data.Ratio + traceIfFalse :: String -> Bool -> Bool traceIfFalse _ a = if a then True else False -checkSwap - :: Integer -- Amount A - -> Integer -- Amount B - -> Integer -- Amount A - -> Integer -- Amount B +checkSwap + :: Integer -- Amount A + -> Integer -- Amount B + -> Integer -- Amount A + -> Integer -- Amount B -> Bool checkSwap oldA oldB newA newB = traceIfFalse "expected positive oldA" (oldA > 0) && @@ -74,3 +78,59 @@ calculateRemoval inA inB liquidity diff = (g inA, g inB) g :: Integer -> Integer g x = x - div (x * diff) liquidity +-- | Integer square-root representation, discarding imaginary integers. +data Sqrt + -- | The number was negative, so we don't even attempt to compute it; + -- just note that the result would be imaginary. + = Imaginary + -- | An exact integer result. The 'rsqrt' of 4 is 'Exactly 2'. + | Exactly Integer + -- | The Integer component (i.e. the floor) of a non-integral result. The + -- 'rsqrt 2' is 'Approximately 1'. + | Approximately Integer + deriving stock (Show, Eq) + +{-# INLINABLE rsqrt #-} +-- | Calculates the sqrt of a ratio of integers. As x / 0 is undefined, +-- calling this function with `d=0` results in an error. +rsqrt :: Rational -> Sqrt +rsqrt r + | n * d < 0 = Imaginary + | n == 0 = Exactly 0 + | n == d = Exactly 1 + | n < d = Approximately 0 + | n < 0 = rsqrt $ negate n % negate d + | otherwise = go 1 $ 1 + div n d + where + n = numerator r + d = denominator r + go :: Integer -> Integer -> Sqrt + go l u + | l * l * d == n = Exactly l + | u == (l + 1) = Approximately l + | otherwise = + let + m = div (l + u) 2 + in + if m * m * d <= n then go m u + else go l m + +calculateAdditionalLiquidity + :: Integer -- Liquidity Pool Balance for first coin of token pool + -> Integer -- Liquidity Pool Balance for second coin of token pool + -> Integer -- Liquidity Pool Balance + -> Integer -- Amount of first coin being added to token pool + -> Integer -- Amount of second coin being added to token pool + -> Integer -- Amount of Liquidity to be recieved +calculateAdditionalLiquidity oldA oldB liquidity delA delB = + case rsqrt ratio of + Imaginary -> (-1) -- TODO: Throw error here + Exactly x -> x - liquidity + Approximately x -> x - liquidity + where + ratio = (liquidity * liquidity * newProd) % oldProd + + oldProd, newProd :: Integer + oldProd = oldA * oldB + newProd = (oldA + delA) * (oldB + delB) + diff --git a/use-case-2/frontend/src/Frontend.hs b/use-case-2/frontend/src/Frontend.hs index d12ebf094..0bfb5a31e 100644 --- a/use-case-2/frontend/src/Frontend.hs +++ b/use-case-2/frontend/src/Frontend.hs @@ -605,6 +605,35 @@ poolDashboard wid = Workflow $ do let newObservableStateTag = incomingWebSocketData ^.. key "tag" . _String failureMessageTag = incomingWebSocketData ^.. key "contents" . key "Left" . _String newObservableStateTag == ["NewObservableState"] && failureMessageTag /= [""] + poolsEvent = flip ffilter (_webSocket_recv ws) $ \(mIncomingWebSocketData :: Maybe Aeson.Value) -> case mIncomingWebSocketData of + Nothing -> False + Just incomingWebSocketData -> do + let observableStateTag = incomingWebSocketData ^.. key "tag" . _String + poolsTag = incomingWebSocketData ^.. key "contents" . key "Right" . key "tag" . _String + observableStateTag == ["NewObservableState"] && poolsTag == ["Pools"] + -- use pool map to calculate and display tokens to be redeemed when removing liquidity + dynPoolMap <- holdDyn Map.empty $ ffor poolsEvent $ \mIncomingPoolsWebSocketData -> do + let poolDetails = case mIncomingPoolsWebSocketData of + Nothing -> V.empty + Just poolsWebSocketData -> poolsWebSocketData ^. key "contents" . key "Right" . key "contents" . _Array + parseLiquidityTokensToMap poolDetails + let ffor4 a b c d f = liftA3 f a b c <*> d + poolSelectionAmounts = ffor4 selectionA amountA selectionB amountB $ \a b c d -> ((a,b),(c,d)) + liquidityEstimate = ffor2 dynPoolMap poolSelectionAmounts $ \poolMap ((selA,amtA) ,(selB, amtB)) -> do + let (liquidityPoolAmount, ((_, coinAPoolAmount), (_, coinBPoolAmount))) = fromMaybe (1,(("",1),("",1))) + $ headMay + $ Map.elems + $ flip Map.filter poolMap + $ \(_, ((nameA,_),(nameB,_))) -> nameA == (_pooledToken_name selA) && nameB == (_pooledToken_name selB) + stakeAmountA :: Integer = fromMaybe 0 $ readMay $ T.unpack amtA + stakeAmountB :: Integer = fromMaybe 0 $ readMay $ T.unpack amtB + calculateAdditionalLiquidity coinAPoolAmount coinBPoolAmount liquidityPoolAmount stakeAmountA stakeAmountB + display liquidityEstimate + divClass "p-3 mt-2" $ widgetHold_ blank $ ffor (updated liquidityEstimate) $ \liqEst -> + elClass "p" "text-info" $ text + $ "Staking this amount to the pool will yield " + <> (T.pack $ show liqEst) + <> " Liquidity Tokens" -- this event will cause the success message to disappear when it occurs vanishEvent <- delay 7 observableStateSuccessEvent -- show success message based on new observable state