View on GitHub
File Changes
--   it to the chain in the context of a wallet.
handleTx :: MonadWallet m => SigningProcess -> UnbalancedTx -> m Tx
handleTx p utx =
-
    balanceWallet utx >>= addSignatures p (unBalancedTxRequiredSignatories utx) >>= WAPI.signTxAndSubmit
+
    balanceWallet utx >>= addSignatures p (Set.toList $ unBalancedTxRequiredSignatories utx) >>= WAPI.signTxAndSubmit

                      
-- | The signing process gets a finished transaction and a list of public keys,
--   and signs the transaction with the corresponding private keys.
import qualified Data.Map                         as Map
import           Data.Semigroup                   (First (..))
import qualified Data.Set                         as Set
+
import Data.Set (Set)
import           Data.Text.Prettyprint.Doc
import           GHC.Generics                     (Generic)
import           IOTS                             (IotsType)
data UnbalancedTx =
    UnbalancedTx
        { unBalancedTxTx                  :: Tx
-
        , unBalancedTxRequiredSignatories :: [PubKeyHash]
+
        , unBalancedTxRequiredSignatories :: Set PubKeyHash
        }
    deriving stock (Eq, Generic)
    deriving anyclass (FromJSON, ToJSON, IotsType)

                      
makeLensesFor [("unBalancedTxTx", "tx"), ("unBalancedTxRequiredSignatories", "requiredSignatories")] ''UnbalancedTx

                      
emptyUnbalancedTx :: UnbalancedTx
-
emptyUnbalancedTx = UnbalancedTx mempty []
+
emptyUnbalancedTx = UnbalancedTx mempty mempty

                      
instance Pretty UnbalancedTx where
    pretty UnbalancedTx{unBalancedTxTx, unBalancedTxRequiredSignatories} =
        vsep
        [ hang 2 $ vsep ["Tx:", pretty unBalancedTxTx]
-
        , hang 2 $ vsep $ "Requires signatures:" : (pretty <$> unBalancedTxRequiredSignatories)
+
        , hang 2 $ vsep $ "Requires signatures:" : (pretty <$> Set.toList unBalancedTxRequiredSignatories)
        ]

                      
data ConstraintProcessingState =
addMissingValueSpent = do
    ConstraintProcessingState{cpsValueSpentActual, cpsValueSpentRequired} <- get

                      
-
    -- 'missing' is everything that's in
+
    -- 'missing' is everything positive (i.e. required) that's in
    -- 'cpsValueSpentRequired' but not in 'cpsValueSpentActual'
    let (_, missing) = Value.split (cpsValueSpentRequired N.- cpsValueSpentActual)

                      
    MustValidateIn slotRange ->
        unbalancedTx . tx . Tx.validRange %= (slotRange /\)
    MustBeSignedBy pk ->
-
        unbalancedTx . requiredSignatories %= (pk :)
+
        unbalancedTx . requiredSignatories %= Set.insert pk
    MustSpendValue vl ->
        valueSpentRequired <>= vl
    MustSpendPubKeyOutput txo -> do
            PubKeyAddress pk -> do
                unbalancedTx . tx . Tx.inputs %= Set.insert (Tx.pubKeyTxIn txo)
                valueSpentActual <>= Tx.txOutValue txOutTxOut
-
                unbalancedTx . requiredSignatories %= (pk :)
+
                unbalancedTx . requiredSignatories %= Set.insert pk
            _                 -> throwError (TxOutRefWrongType txo)
    MustSpendScriptOutput txo red -> do
        txOutTx <- lookupTxOutRef txo
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
-
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
-
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
module Ledger.Typed.TypeUtils where

                      
-
import           Data.Aeson         (FromJSON (..), ToJSON (..))
-
import           Data.Proxy         (Proxy (..))
-

                      
import           Data.Kind
-
import           Data.Type.Equality
-
import           GHC.TypeLits

                      
-- | A heterogeneous list where every element is wrapped with the given functor.
data HListF (f :: Type -> Type) (l :: [Type]) where
hfOut :: forall o f (ts :: [Type]) . (forall a . f a -> o) -> HListF f ts -> [o]
hfOut _ HNilF         = []
hfOut f (HConsF e es) = f e : hfOut f es
-

                      
-
-- | The first element of a heterogeneous list.
-
hfHead :: forall f t (ts :: [Type]) . HListF f (t ': ts) -> f t
-
hfHead (HConsF e _) = e
-

                      
-
data LengthList (n :: Nat) a where
-
  LLNil :: LengthList 0 a
-
  LLCons :: a -> LengthList n a -> LengthList (n+1) a
-

                      
-
instance (Eq a) => Eq (LengthList n a) where
-
  l == r = llList l == llList r
-

                      
-
instance ToJSON a => ToJSON (LengthList n a) where
-
  toJSON = toJSON . llList
-

                      
-
instance (KnownNat n, FromJSON a) => FromJSON (LengthList n a) where
-
  parseJSON v = parseJSON v >>= maybe (fail "Wrong length") pure . fromList' @n
-

                      
-
data SomeLengthList a =
-
  forall n. KnownNat n => SomeLengthList (LengthList n a)
-

                      
-
slCons :: a -> SomeLengthList a -> SomeLengthList a
-
slCons a (SomeLengthList l) = case l of
-
    LLNil       -> SomeLengthList (LLCons a LLNil)
-
    LLCons x xs -> SomeLengthList (LLCons x xs)
-

                      
-
slNil :: SomeLengthList a
-
slNil = SomeLengthList LLNil
-

                      
-
llList :: LengthList n a -> [a]
-
llList = \case
-
  LLNil -> []
-
  LLCons x xs -> x : llList xs
-

                      
-
fromList' :: forall n a. KnownNat n => [a] -> Maybe (LengthList n a)
-
fromList' xs = case fromList xs of
-
  SomeLengthList (p2 :: LengthList n2 a) ->
-
    case sameNat (Proxy @n) (Proxy @n2) of
-
      Nothing   -> Nothing
-
      Just Refl -> Just p2
-

                      
-
fromList :: [a] -> SomeLengthList a
-
fromList = foldl (flip slCons) slNil
-

                      
-
instance Eq a => Eq (SomeLengthList a) where
-
  (SomeLengthList xs) == (SomeLengthList ys) =
-
    llList xs == llList ys
-

                      
-
instance ToJSON a => ToJSON (SomeLengthList a) where
-
  toJSON = \case { SomeLengthList ll -> toJSON (llList ll) }
-

                      
-
instance FromJSON a => FromJSON (SomeLengthList a) where
-
  parseJSON = fmap fromList . parseJSON
makeLift ''CurrencySymbol

                      
{-# INLINABLE mpsSymbol #-}
-
-- TODO (jm): Get rid of 'CurrencySymbol' and just use MPS Hash everywhere
-
-- (likely affects the Playground so I'd like to do it in a separate PR)
-- | The currency symbol of a monetay policy hash
mpsSymbol :: MonetaryPolicyHash -> CurrencySymbol
mpsSymbol (MonetaryPolicyHash h) = CurrencySymbol h