{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:coverage-all #-}

module Plutus.Contracts.Uniswap.OnChain
    ( mkUniswapValidator
    , validateLiquidityMinting
    ) where

import Data.Void (Void)
import Ledger ()
import Ledger.Tx.Constraints as Constraints
import Ledger.Tx.Constraints.OnChain.V2 as Constraints
import Plutus.Contracts.Uniswap.Pool (calculateAdditionalLiquidity, calculateInitialLiquidity, calculateRemoval,
                                      checkSwap, lpTicker)
import Plutus.Contracts.Uniswap.Types
import Plutus.Script.Utils.Value (AssetClass (..), symbols)
import Plutus.V2.Ledger.Api (Datum (Datum), DatumHash, OutputDatum (..), ScriptContext (..), TokenName,
                             TxInInfo (txInInfoResolved), TxInfo (txInfoInputs, txInfoMint),
                             TxOut (txOutDatum, txOutValue), Value)
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified
import PlutusTx.Prelude

{-# INLINABLE findOwnInput' #-}
findOwnInput' :: ScriptContext -> TxInInfo
findOwnInput' :: ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx = TxInInfo -> Maybe TxInInfo -> TxInInfo
forall a. a -> Maybe a -> a
fromMaybe (() -> TxInInfo
forall a. () -> a
error ()) (ScriptContext -> Maybe TxInInfo
V2.findOwnInput ScriptContext
ctx)

{-# INLINABLE valueWithin #-}
valueWithin :: TxInInfo -> Value
valueWithin :: TxInInfo -> Value
valueWithin = TxOut -> Value
txOutValue (TxOut -> Value) -> (TxInInfo -> TxOut) -> TxInInfo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved

{-# INLINABLE validateSwap #-}
-- | We check the swap is valid through 'checkSwap', and otherwise just make
-- sure that the pool token is passed through.
validateSwap :: LiquidityPool -> Coin PoolState -> ScriptContext -> Bool
validateSwap :: LiquidityPool -> Coin PoolState -> ScriptContext -> Bool
validateSwap LiquidityPool{Coin A
Coin B
lpCoinB :: LiquidityPool -> Coin B
lpCoinA :: LiquidityPool -> Coin A
lpCoinB :: Coin B
lpCoinA :: Coin A
..} Coin PoolState
c ScriptContext
ctx =
    Amount A -> Amount B -> Amount A -> Amount B -> Bool
checkSwap Amount A
oldA Amount B
oldB Amount A
newA Amount B
newB                                                       Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected pool state token to be present in input" (Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
inVal Coin PoolState
c)   Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"expected pool state token to be present in output" (Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
outVal Coin PoolState
c) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"did not expect Uniswap minting" Bool
noUniswapMinting
  where
    info :: TxInfo
    info :: TxInfo
info = ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    ownInput :: TxInInfo
    ownInput :: TxInInfo
ownInput = ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx

    ownOutput :: TxOut
    ownOutput :: TxOut
ownOutput = case [ TxOut
o
                     | TxOut
o <- ScriptContext -> [TxOut]
V2.getContinuingOutputs ScriptContext
ctx
                     , TxOut -> OutputDatum
txOutDatum TxOut
o OutputDatum -> OutputDatum -> Bool
forall a. Eq a => a -> a -> Bool
== ((ValidatorHash, OutputDatum) -> OutputDatum
forall a b. (a, b) -> b
snd ((ValidatorHash, OutputDatum) -> OutputDatum)
-> (ValidatorHash, OutputDatum) -> OutputDatum
forall a b. (a -> b) -> a -> b
$ ScriptContext -> (ValidatorHash, OutputDatum)
V2.ownHashes ScriptContext
ctx)
                     ] of
        [TxOut
o] -> TxOut
o
        [TxOut]
_   -> BuiltinString -> TxOut
forall a. BuiltinString -> a
traceError BuiltinString
"expected exactly one output to the same liquidity pool"

    oldA :: Amount A
oldA = Value -> Amount A
amountA Value
inVal
    oldB :: Amount B
oldB = Value -> Amount B
amountB Value
inVal
    newA :: Amount A
newA = Value -> Amount A
amountA Value
outVal
    newB :: Amount B
newB = Value -> Amount B
amountB Value
outVal

    amountA :: Value -> Amount A
amountA Value
v = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf Value
v Coin A
lpCoinA
    amountB :: Value -> Amount B
amountB Value
v = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf Value
v Coin B
lpCoinB

    inVal, outVal :: Value
    inVal :: Value
inVal  = TxInInfo -> Value
valueWithin TxInInfo
ownInput
    outVal :: Value
outVal = TxOut -> Value
txOutValue TxOut
ownOutput

    noUniswapMinting :: Bool
    noUniswapMinting :: Bool
noUniswapMinting =
      let
        AssetClass (CurrencySymbol
cs, TokenName
_) = Coin PoolState -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin PoolState
c
        minted :: Value
minted             = TxInfo -> Value
txInfoMint TxInfo
info
      in
        CurrencySymbol -> [CurrencySymbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem CurrencySymbol
cs ([CurrencySymbol] -> Bool) -> [CurrencySymbol] -> Bool
forall a b. (a -> b) -> a -> b
$ Value -> [CurrencySymbol]
symbols Value
minted

{-# INLINABLE validateCreate #-}
-- | Ths validates the creation of a liquidity pool to exchange coins. In order to be
-- valid,
--
--  1,2. We need to be dealing with the Uniswap coin,
--  3. We have to exchanging different coins,
--  4. The pool can't already exist,
--  5. The pool needs a single value as output,
--  6. The liquidity amount needs to be as-determined by 'calculateInitialLiquidity'
--      (i.e. the amount from the Uniswap V2 paper).
--  7,8. We need to be exchanging more than zero of each kind of coin.
--  9. It should output a pool with the determined properties
validateCreate :: Uniswap
               -> Coin PoolState
               -> [LiquidityPool]
               -> LiquidityPool
               -> ScriptContext
               -> Bool
validateCreate :: Uniswap
-> Coin PoolState
-> [LiquidityPool]
-> LiquidityPool
-> ScriptContext
-> Bool
validateCreate Uniswap{Coin U
usCoin :: Uniswap -> Coin U
usCoin :: Coin U
..} Coin PoolState
c [LiquidityPool]
lps lp :: LiquidityPool
lp@LiquidityPool{Coin A
Coin B
lpCoinB :: Coin B
lpCoinA :: Coin A
lpCoinB :: LiquidityPool -> Coin B
lpCoinA :: LiquidityPool -> Coin A
..} ScriptContext
ctx =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Uniswap coin not present" (Value -> Coin U -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxInInfo -> Value
valueWithin (TxInInfo -> Value) -> TxInInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx) Coin U
usCoin)     Bool -> Bool -> Bool
&& -- 1.
    TxConstraints Void UniswapDatum -> ScriptContext -> Bool
forall i o.
(ToData i, ToData o) =>
TxConstraints i o -> ScriptContext -> Bool
Constraints.checkScriptContext @Void @UniswapDatum
        (UniswapDatum -> Value -> TxConstraints Void UniswapDatum
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithDatumInTx
            ([LiquidityPool] -> UniswapDatum
Factory ([LiquidityPool] -> UniswapDatum)
-> [LiquidityPool] -> UniswapDatum
forall a b. (a -> b) -> a -> b
$ LiquidityPool
lp LiquidityPool -> [LiquidityPool] -> [LiquidityPool]
forall a. a -> [a] -> [a]
: [LiquidityPool]
lps)
            (Coin U -> Value
forall a. Coin a -> Value
unitValue Coin U
usCoin))
        ScriptContext
ctx                                                                                        Bool -> Bool -> Bool
&& -- 2.
    (Coin A -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin A
lpCoinA AssetClass -> AssetClass -> Bool
forall a. Eq a => a -> a -> Bool
/= Coin B -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin B
lpCoinB)                                                             Bool -> Bool -> Bool
&& -- 3.
    LiquidityPool -> [LiquidityPool] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem LiquidityPool
lp [LiquidityPool]
lps                                                                                 Bool -> Bool -> Bool
&& -- 4.
    Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
minted Coin PoolState
c                                                                               Bool -> Bool -> Bool
&& -- 5.
    (Value -> Coin Liquidity -> Amount Liquidity
forall a. Value -> Coin a -> Amount a
amountOf Value
minted Coin Liquidity
liquidityCoin' Amount Liquidity -> Amount Liquidity -> Bool
forall a. Eq a => a -> a -> Bool
== Amount Liquidity
liquidity)                                                  Bool -> Bool -> Bool
&& -- 6.
    (Amount A
outA Amount A -> Amount A -> Bool
forall a. Ord a => a -> a -> Bool
> Amount A
0)                                                                                     Bool -> Bool -> Bool
&& -- 7.
    (Amount B
outB Amount B -> Amount B -> Bool
forall a. Ord a => a -> a -> Bool
> Amount B
0)                                                                                     Bool -> Bool -> Bool
&& -- 8.
    TxConstraints Void UniswapDatum -> ScriptContext -> Bool
forall i o.
(ToData i, ToData o) =>
TxConstraints i o -> ScriptContext -> Bool
Constraints.checkScriptContext @Void @UniswapDatum
        (UniswapDatum -> Value -> TxConstraints Void UniswapDatum
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithDatumInTx
            (LiquidityPool -> Amount Liquidity -> UniswapDatum
Pool LiquidityPool
lp Amount Liquidity
liquidity)
            (Coin A -> Amount A -> Value
forall a. Coin a -> Amount a -> Value
valueOf Coin A
lpCoinA Amount A
outA Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Coin B -> Amount B -> Value
forall a. Coin a -> Amount a -> Value
valueOf Coin B
lpCoinB Amount B
outB Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Coin PoolState -> Value
forall a. Coin a -> Value
unitValue Coin PoolState
c))
        ScriptContext
ctx
  where
    poolOutput :: TxOut
    poolOutput :: TxOut
poolOutput = case [TxOut
o | TxOut
o <- ScriptContext -> [TxOut]
V2.getContinuingOutputs ScriptContext
ctx, Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxOut -> Value
txOutValue TxOut
o) Coin PoolState
c] of
        [TxOut
o] -> TxOut
o
        [TxOut]
_   -> BuiltinString -> TxOut
forall a. BuiltinString -> a
traceError BuiltinString
"expected exactly one pool output"

    outA :: Amount A
outA      = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf (TxOut -> Value
txOutValue TxOut
poolOutput) Coin A
lpCoinA
    outB :: Amount B
outB      = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf (TxOut -> Value
txOutValue TxOut
poolOutput) Coin B
lpCoinB
    liquidity :: Amount Liquidity
liquidity = Amount A -> Amount B -> Amount Liquidity
calculateInitialLiquidity Amount A
outA Amount B
outB

    minted :: Value
    minted :: Value
minted = TxInfo -> Value
txInfoMint (TxInfo -> Value) -> TxInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    liquidityCoin' :: Coin Liquidity
    liquidityCoin' :: Coin Liquidity
liquidityCoin' = let AssetClass (CurrencySymbol
cs,TokenName
_) = Coin PoolState -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin PoolState
c in CurrencySymbol -> TokenName -> Coin Liquidity
forall a. CurrencySymbol -> TokenName -> Coin a
mkCoin CurrencySymbol
cs (TokenName -> Coin Liquidity) -> TokenName -> Coin Liquidity
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> TokenName
lpTicker LiquidityPool
lp

{-# INLINABLE validateCloseFactory #-}
-- | See 'Plutus.Contracts.Uniswap.OffChain.close'.
validateCloseFactory :: Uniswap -> Coin PoolState -> [LiquidityPool] -> ScriptContext -> Bool
validateCloseFactory :: Uniswap
-> Coin PoolState -> [LiquidityPool] -> ScriptContext -> Bool
validateCloseFactory Uniswap{Coin U
usCoin :: Coin U
usCoin :: Uniswap -> Coin U
..} Coin PoolState
c [LiquidityPool]
lps ScriptContext
ctx =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Uniswap coin not present" (Value -> Coin U -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxInInfo -> Value
valueWithin (TxInInfo -> Value) -> TxInInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx) Coin U
usCoin)                        Bool -> Bool -> Bool
&& -- 1.
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"wrong mint value"        (TxInfo -> Value
txInfoMint TxInfo
info Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Value
forall a. AdditiveGroup a => a -> a
negate (Coin PoolState -> Value
forall a. Coin a -> Value
unitValue Coin PoolState
c Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<>  Coin Liquidity -> Amount Liquidity -> Value
forall a. Coin a -> Amount a -> Value
valueOf Coin Liquidity
lC ((LiquidityPool, Amount Liquidity) -> Amount Liquidity
forall a b. (a, b) -> b
snd (LiquidityPool, Amount Liquidity)
lpLiquidity))) Bool -> Bool -> Bool
&& -- 2.
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"factory output wrong"                                                                                  -- 3.
        ( TxConstraints Void UniswapDatum -> ScriptContext -> Bool
forall i o.
(ToData i, ToData o) =>
TxConstraints i o -> ScriptContext -> Bool
Constraints.checkScriptContext @Void @UniswapDatum
            (UniswapDatum -> Value -> TxConstraints Void UniswapDatum
forall o i. o -> Value -> TxConstraints i o
mustPayToTheScriptWithDatumInTx
                ([LiquidityPool] -> UniswapDatum
Factory ([LiquidityPool] -> UniswapDatum)
-> [LiquidityPool] -> UniswapDatum
forall a b. (a -> b) -> a -> b
$ (LiquidityPool -> Bool) -> [LiquidityPool] -> [LiquidityPool]
forall a. (a -> Bool) -> [a] -> [a]
filter (LiquidityPool -> LiquidityPool -> Bool
forall a. Eq a => a -> a -> Bool
/= (LiquidityPool, Amount Liquidity) -> LiquidityPool
forall a b. (a, b) -> a
fst (LiquidityPool, Amount Liquidity)
lpLiquidity) [LiquidityPool]
lps)
                (Coin U -> Value
forall a. Coin a -> Value
unitValue Coin U
usCoin))
            ScriptContext
ctx
        )
  where
    info :: TxInfo
    info :: TxInfo
info = ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    poolInput :: TxInInfo
    poolInput :: TxInInfo
poolInput = case [ TxInInfo
i
                     | TxInInfo
i <- TxInfo -> [TxInInfo]
txInfoInputs TxInfo
info
                     , Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxInInfo -> Value
valueWithin TxInInfo
i) Coin PoolState
c
                     ] of
        [TxInInfo
i] -> TxInInfo
i
        [TxInInfo]
_   -> BuiltinString -> TxInInfo
forall a. BuiltinString -> a
traceError BuiltinString
"expected exactly one pool input"

    lpLiquidity :: (LiquidityPool, Amount Liquidity)
    lpLiquidity :: (LiquidityPool, Amount Liquidity)
lpLiquidity = case TxOut -> OutputDatum
txOutDatum (TxOut -> OutputDatum)
-> (TxInInfo -> TxOut) -> TxInInfo -> OutputDatum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved (TxInInfo -> OutputDatum) -> TxInInfo -> OutputDatum
forall a b. (a -> b) -> a -> b
$ TxInInfo
poolInput of
        OutputDatum
NoOutputDatum         -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"pool input witness missing"
        OutputDatumHash DatumHash
dh    -> TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity)
findPoolDatum TxInfo
info DatumHash
dh
        OutputDatum (Datum BuiltinData
d) -> case BuiltinData -> UniswapDatum
forall a. UnsafeFromData a => BuiltinData -> a
PlutusTx.unsafeFromBuiltinData BuiltinData
d of
                                  (Pool LiquidityPool
lp Amount Liquidity
a) -> (LiquidityPool
lp, Amount Liquidity
a)
                                  UniswapDatum
_           -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"error decoding data"

    lC :: Coin Liquidity
    lC :: Coin Liquidity
lC  = let AssetClass (CurrencySymbol
cs, TokenName
_) = Coin PoolState -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin PoolState
c in CurrencySymbol -> TokenName -> Coin Liquidity
forall a. CurrencySymbol -> TokenName -> Coin a
mkCoin CurrencySymbol
cs (LiquidityPool -> TokenName
lpTicker (LiquidityPool -> TokenName) -> LiquidityPool -> TokenName
forall a b. (a -> b) -> a -> b
$ (LiquidityPool, Amount Liquidity) -> LiquidityPool
forall a b. (a, b) -> a
fst (LiquidityPool, Amount Liquidity)
lpLiquidity)

{-# INLINABLE validateClosePool #-}
-- | See 'Plutus.Contracts.Uniswap.OffChain.close'.
validateClosePool :: Uniswap -> ScriptContext -> Bool
validateClosePool :: Uniswap -> ScriptContext -> Bool
validateClosePool Uniswap
us ScriptContext
ctx = Bool
hasFactoryInput
  where
    info :: TxInfo
    info :: TxInfo
info = ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    hasFactoryInput :: Bool
    hasFactoryInput :: Bool
hasFactoryInput =
        BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"Uniswap factory input expected" (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
        Value -> Coin U -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxInfo -> Value
V2.valueSpent TxInfo
info) (Uniswap -> Coin U
usCoin Uniswap
us)

{-# INLINABLE validateRemove #-}
-- | See 'Plutus.Contracts.Uniswap.OffChain.remove'.
validateRemove :: Coin PoolState -> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateRemove :: Coin PoolState
-> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateRemove Coin PoolState
c LiquidityPool
lp Amount Liquidity
liquidity ScriptContext
ctx =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"zero removal"                        (Amount Liquidity
diff Amount Liquidity -> Amount Liquidity -> Bool
forall a. Ord a => a -> a -> Bool
> Amount Liquidity
0)                                     Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"removal of too much liquidity"       (Amount Liquidity
diff Amount Liquidity -> Amount Liquidity -> Bool
forall a. Ord a => a -> a -> Bool
< Amount Liquidity
liquidity)                             Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"pool state coin missing"             (Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
inVal Coin PoolState
c)                              Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"wrong liquidity pool output"         ((LiquidityPool, Amount Liquidity) -> LiquidityPool
forall a b. (a, b) -> a
fst (LiquidityPool, Amount Liquidity)
lpLiquidity LiquidityPool -> LiquidityPool -> Bool
forall a. Eq a => a -> a -> Bool
== LiquidityPool
lp)                        Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"pool state coin missing from output" (Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
outVal Coin PoolState
c)                             Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"liquidity tokens not burnt"          (TxInfo -> Value
txInfoMint TxInfo
info Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Value
forall a. AdditiveGroup a => a -> a
negate (Coin Liquidity -> Amount Liquidity -> Value
forall a. Coin a -> Amount a -> Value
valueOf Coin Liquidity
lC Amount Liquidity
diff))  Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"non-positive liquidity"              (Amount A
outA Amount A -> Amount A -> Bool
forall a. Ord a => a -> a -> Bool
> Amount A
0 Bool -> Bool -> Bool
&& Amount B
outB Amount B -> Amount B -> Bool
forall a. Ord a => a -> a -> Bool
> Amount B
0)                         Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"removal of invalid amount of tokens" (Amount A
outA' Amount A -> Amount A -> Bool
forall a. Eq a => a -> a -> Bool
== Amount A
outA Bool -> Bool -> Bool
&& Amount B
outB' Amount B -> Amount B -> Bool
forall a. Eq a => a -> a -> Bool
== Amount B
outB)
  where
    info :: TxInfo
    info :: TxInfo
info = ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    ownInput :: TxInInfo
    ownInput :: TxInInfo
ownInput = ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx

    output :: TxOut
    output :: TxOut
output = case ScriptContext -> [TxOut]
V2.getContinuingOutputs ScriptContext
ctx of
        [TxOut
o] -> TxOut
o
        [TxOut]
_   -> BuiltinString -> TxOut
forall a. BuiltinString -> a
traceError BuiltinString
"expected exactly one Uniswap output"

    inVal, outVal :: Value
    inVal :: Value
inVal  = TxInInfo -> Value
valueWithin TxInInfo
ownInput
    outVal :: Value
outVal = TxOut -> Value
txOutValue TxOut
output

    lpLiquidity :: (LiquidityPool, Amount Liquidity)
    lpLiquidity :: (LiquidityPool, Amount Liquidity)
lpLiquidity = case TxOut -> OutputDatum
txOutDatum TxOut
output of
        OutputDatum
NoOutputDatum         -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"pool output witness missing"
        OutputDatumHash DatumHash
dh    -> TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity)
findPoolDatum TxInfo
info DatumHash
dh
        OutputDatum (Datum BuiltinData
d) -> case BuiltinData -> UniswapDatum
forall a. UnsafeFromData a => BuiltinData -> a
PlutusTx.unsafeFromBuiltinData BuiltinData
d of
                                  (Pool LiquidityPool
lp' Amount Liquidity
a) -> (LiquidityPool
lp', Amount Liquidity
a)
                                  UniswapDatum
_            -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"error decoding data"

    lC :: Coin Liquidity
    lC :: Coin Liquidity
lC = let AssetClass (CurrencySymbol
cs, TokenName
_) = Coin PoolState -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin PoolState
c in CurrencySymbol -> TokenName -> Coin Liquidity
forall a. CurrencySymbol -> TokenName -> Coin a
mkCoin CurrencySymbol
cs (LiquidityPool -> TokenName
lpTicker LiquidityPool
lp)

    diff :: Amount Liquidity
diff         = Amount Liquidity
liquidity Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. AdditiveGroup a => a -> a -> a
- (LiquidityPool, Amount Liquidity) -> Amount Liquidity
forall a b. (a, b) -> b
snd (LiquidityPool, Amount Liquidity)
lpLiquidity
    inA :: Amount A
inA          = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf Value
inVal (Coin A -> Amount A) -> Coin A -> Amount A
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> Coin A
lpCoinA LiquidityPool
lp
    inB :: Amount B
inB          = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf Value
inVal (Coin B -> Amount B) -> Coin B -> Amount B
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> Coin B
lpCoinB LiquidityPool
lp
    outA' :: Amount A
outA'        = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf Value
outVal (Coin A -> Amount A) -> Coin A -> Amount A
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> Coin A
lpCoinA LiquidityPool
lp
    outB' :: Amount B
outB'        = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf Value
outVal (Coin B -> Amount B) -> Coin B -> Amount B
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> Coin B
lpCoinB LiquidityPool
lp
    (Amount A
outA, Amount B
outB) = Amount A
-> Amount B
-> Amount Liquidity
-> Amount Liquidity
-> (Amount A, Amount B)
calculateRemoval Amount A
inA Amount B
inB Amount Liquidity
liquidity Amount Liquidity
diff

{-# INLINABLE validateAdd #-}
-- | See 'Plutus.Contracts.Uniswap.OffChain.add'.
validateAdd :: Coin PoolState -> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateAdd :: Coin PoolState
-> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateAdd Coin PoolState
c LiquidityPool
lp Amount Liquidity
liquidity ScriptContext
ctx =
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"pool stake token missing from input"          (Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
inVal Coin PoolState
c)                                                    Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"output pool for same liquidity pair expected" (LiquidityPool
lp LiquidityPool -> LiquidityPool -> Bool
forall a. Eq a => a -> a -> Bool
== (LiquidityPool, Amount Liquidity) -> LiquidityPool
forall a b. (a, b) -> a
fst (LiquidityPool, Amount Liquidity)
outDatum)                                                 Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"must not remove tokens"                       (Amount A
delA Amount A -> Amount A -> Bool
forall a. Ord a => a -> a -> Bool
>= Amount A
0 Bool -> Bool -> Bool
&& Amount B
delB Amount B -> Amount B -> Bool
forall a. Ord a => a -> a -> Bool
>= Amount B
0)                                             Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"insufficient liquidity"                       (Amount Liquidity
delL Amount Liquidity -> Amount Liquidity -> Bool
forall a. Ord a => a -> a -> Bool
>= Amount Liquidity
0)                                                          Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"wrong amount of liquidity tokens"             (Amount Liquidity
delL Amount Liquidity -> Amount Liquidity -> Bool
forall a. Eq a => a -> a -> Bool
== Amount A
-> Amount B
-> Amount Liquidity
-> Amount A
-> Amount B
-> Amount Liquidity
calculateAdditionalLiquidity Amount A
oldA Amount B
oldB Amount Liquidity
liquidity Amount A
delA Amount B
delB) Bool -> Bool -> Bool
&&
    BuiltinString -> Bool -> Bool
traceIfFalse BuiltinString
"wrong amount of liquidity tokens minted"      (TxInfo -> Value
txInfoMint TxInfo
info Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Coin Liquidity -> Amount Liquidity -> Value
forall a. Coin a -> Amount a -> Value
valueOf Coin Liquidity
lC Amount Liquidity
delL)
  where
    info :: TxInfo
    info :: TxInfo
info = ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx

    ownInput :: TxInInfo
    ownInput :: TxInInfo
ownInput = ScriptContext -> TxInInfo
findOwnInput' ScriptContext
ctx

    ownOutput :: TxOut
    ownOutput :: TxOut
ownOutput = case [ TxOut
o
                     | TxOut
o <- ScriptContext -> [TxOut]
V2.getContinuingOutputs ScriptContext
ctx
                     , Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity (TxOut -> Value
txOutValue TxOut
o) Coin PoolState
c
                     ] of
        [TxOut
o] -> TxOut
o
        [TxOut]
_   -> BuiltinString -> TxOut
forall a. BuiltinString -> a
traceError BuiltinString
"expected exactly on pool output"

    outDatum :: (LiquidityPool, Amount Liquidity)
    outDatum :: (LiquidityPool, Amount Liquidity)
outDatum = case TxOut -> OutputDatum
txOutDatum TxOut
ownOutput of
        OutputDatum
NoOutputDatum         -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"pool output datum/hash not found"
        OutputDatumHash DatumHash
dh    -> TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity)
findPoolDatum TxInfo
info DatumHash
dh
        OutputDatum (Datum BuiltinData
d) -> case BuiltinData -> UniswapDatum
forall a. UnsafeFromData a => BuiltinData -> a
PlutusTx.unsafeFromBuiltinData BuiltinData
d of
                                  (Pool LiquidityPool
lp' Amount Liquidity
a) -> (LiquidityPool
lp', Amount Liquidity
a)
                                  UniswapDatum
_            -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"error decoding data"

    inVal, outVal :: Value
    inVal :: Value
inVal  = TxInInfo -> Value
valueWithin TxInInfo
ownInput
    outVal :: Value
outVal = TxOut -> Value
txOutValue TxOut
ownOutput

    oldA :: Amount A
oldA = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf Value
inVal Coin A
aC
    oldB :: Amount B
oldB = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf Value
inVal Coin B
bC
    delA :: Amount A
delA = Value -> Coin A -> Amount A
forall a. Value -> Coin a -> Amount a
amountOf Value
outVal Coin A
aC Amount A -> Amount A -> Amount A
forall a. AdditiveGroup a => a -> a -> a
- Amount A
oldA
    delB :: Amount B
delB = Value -> Coin B -> Amount B
forall a. Value -> Coin a -> Amount a
amountOf Value
outVal Coin B
bC Amount B -> Amount B -> Amount B
forall a. AdditiveGroup a => a -> a -> a
- Amount B
oldB
    delL :: Amount Liquidity
delL = (LiquidityPool, Amount Liquidity) -> Amount Liquidity
forall a b. (a, b) -> b
snd (LiquidityPool, Amount Liquidity)
outDatum Amount Liquidity -> Amount Liquidity -> Amount Liquidity
forall a. AdditiveGroup a => a -> a -> a
- Amount Liquidity
liquidity

    aC :: Coin A
aC = LiquidityPool -> Coin A
lpCoinA LiquidityPool
lp
    bC :: Coin B
bC = LiquidityPool -> Coin B
lpCoinB LiquidityPool
lp

    lC :: Coin Liquidity
    lC :: Coin Liquidity
lC = let AssetClass (CurrencySymbol
cs, TokenName
_) = Coin PoolState -> AssetClass
forall a. Coin a -> AssetClass
unCoin Coin PoolState
c in CurrencySymbol -> TokenName -> Coin Liquidity
forall a. CurrencySymbol -> TokenName -> Coin a
mkCoin CurrencySymbol
cs (TokenName -> Coin Liquidity) -> TokenName -> Coin Liquidity
forall a b. (a -> b) -> a -> b
$ LiquidityPool -> TokenName
lpTicker LiquidityPool
lp

{-# INLINABLE findPoolDatum #-}
findPoolDatum :: TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity)
findPoolDatum :: TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity)
findPoolDatum TxInfo
info DatumHash
h = case DatumHash -> TxInfo -> Maybe Datum
V2.findDatum DatumHash
h TxInfo
info of
    Just (Datum BuiltinData
d) -> case BuiltinData -> UniswapDatum
forall a. UnsafeFromData a => BuiltinData -> a
PlutusTx.unsafeFromBuiltinData BuiltinData
d of
        (Pool LiquidityPool
lp Amount Liquidity
a) -> (LiquidityPool
lp, Amount Liquidity
a)
        UniswapDatum
_           -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"error decoding data"
    Maybe Datum
_              -> BuiltinString -> (LiquidityPool, Amount Liquidity)
forall a. BuiltinString -> a
traceError BuiltinString
"pool input datum not found"

{-# INLINABLE mkUniswapValidator #-}
mkUniswapValidator :: Uniswap
                   -> Coin PoolState
                   -> UniswapDatum
                   -> UniswapAction
                   -> ScriptContext
                   -> Bool
mkUniswapValidator :: Uniswap
-> Coin PoolState
-> UniswapDatum
-> UniswapAction
-> ScriptContext
-> Bool
mkUniswapValidator Uniswap
us Coin PoolState
c (Factory [LiquidityPool]
lps) (Create LiquidityPool
lp) ScriptContext
ctx = Uniswap
-> Coin PoolState
-> [LiquidityPool]
-> LiquidityPool
-> ScriptContext
-> Bool
validateCreate Uniswap
us Coin PoolState
c [LiquidityPool]
lps LiquidityPool
lp ScriptContext
ctx
mkUniswapValidator Uniswap
_  Coin PoolState
c (Pool LiquidityPool
lp Amount Liquidity
_)   UniswapAction
Swap        ScriptContext
ctx = LiquidityPool -> Coin PoolState -> ScriptContext -> Bool
validateSwap LiquidityPool
lp Coin PoolState
c ScriptContext
ctx
mkUniswapValidator Uniswap
us Coin PoolState
c (Factory [LiquidityPool]
lps) UniswapAction
Close       ScriptContext
ctx = Uniswap
-> Coin PoolState -> [LiquidityPool] -> ScriptContext -> Bool
validateCloseFactory Uniswap
us Coin PoolState
c [LiquidityPool]
lps ScriptContext
ctx
mkUniswapValidator Uniswap
us Coin PoolState
_ (Pool LiquidityPool
_  Amount Liquidity
_)   UniswapAction
Close       ScriptContext
ctx = Uniswap -> ScriptContext -> Bool
validateClosePool Uniswap
us ScriptContext
ctx
mkUniswapValidator Uniswap
_  Coin PoolState
c (Pool LiquidityPool
lp Amount Liquidity
a)   UniswapAction
Remove      ScriptContext
ctx = Coin PoolState
-> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateRemove Coin PoolState
c LiquidityPool
lp Amount Liquidity
a ScriptContext
ctx
mkUniswapValidator Uniswap
_  Coin PoolState
c (Pool LiquidityPool
lp Amount Liquidity
a)   UniswapAction
Add         ScriptContext
ctx = Coin PoolState
-> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool
validateAdd Coin PoolState
c LiquidityPool
lp Amount Liquidity
a ScriptContext
ctx
mkUniswapValidator Uniswap
_  Coin PoolState
_ UniswapDatum
_             UniswapAction
_           ScriptContext
_   = Bool
False

{-# INLINABLE validateLiquidityMinting #-}
validateLiquidityMinting :: Uniswap -> TokenName -> () -> ScriptContext -> Bool
validateLiquidityMinting :: Uniswap -> TokenName -> () -> ScriptContext -> Bool
validateLiquidityMinting Uniswap{Coin U
usCoin :: Coin U
usCoin :: Uniswap -> Coin U
..} TokenName
tn ()
_ ScriptContext
ctx
  = case [ TxInInfo
i
         | TxInInfo
i <- TxInfo -> [TxInInfo]
txInfoInputs (TxInfo -> [TxInInfo]) -> TxInfo -> [TxInInfo]
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx
         , let v :: Value
v = TxInInfo -> Value
valueWithin TxInInfo
i
         , Value -> Coin U -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
v Coin U
usCoin Bool -> Bool -> Bool
|| Value -> Coin PoolState -> Bool
forall a. Value -> Coin a -> Bool
isUnity Value
v Coin PoolState
lpC
         ] of
    [TxInInfo
_]    -> Bool
True
    [TxInInfo
_, TxInInfo
_] -> Bool
True
    [TxInInfo]
_      -> BuiltinString -> Bool
forall a. BuiltinString -> a
traceError BuiltinString
"pool state minting without Uniswap input"
  where
    lpC :: Coin PoolState
    lpC :: Coin PoolState
lpC = CurrencySymbol -> TokenName -> Coin PoolState
forall a. CurrencySymbol -> TokenName -> Coin a
mkCoin (ScriptContext -> CurrencySymbol
V2.ownCurrencySymbol ScriptContext
ctx) TokenName
tn