Mark prop_balanceTransactionUnresolvedInputs pending

lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs

@@ -329,6 +329,7 @@ import Test.Hspec
     , shouldBe
     , shouldSatisfy
     , xdescribe
+    , xit
     )
 import Test.Hspec.Core.Spec
     ( SpecM )
@@ -2247,7 +2248,7 @@ balanceTransactionSpec = do
                 tx `shouldBe` Left ErrBalanceTxMaxSizeLimitExceeded
 
         describe "when passed unresolved inputs" $ do
-            it "may fail"
+            xit "may fail"
                 $ property prop_balanceTransactionUnresolvedInputs
 
     describe "sizeOfCoin" $ do
@@ -2983,32 +2984,53 @@ balanceTransaction' (Wallet' utxo wal pending) seed tx  =
 
 -- | Tests that 'TranslationLogicMissingInput' can in fact be returned by
 -- 'balanceTransaction'.
+--
+-- FIXME: Coverage is too poor. It might be best to replace with one or two
+-- simple unit tests instead. (one where dropping input resulted in an error
+-- like 'TranslationLogicMissingInput' and one where it succeeded anyway because
+-- of the wallet utxo)
 prop_balanceTransactionUnresolvedInputs
-    :: Wallet'
-    -> ShowBuildable (PartialTx Cardano.AlonzoEra)
+    :: (ShowBuildable (PartialTx Cardano.AlonzoEra))
     -> StdGenSeed
     -> Property
-prop_balanceTransactionUnresolvedInputs wallet (ShowBuildable partialTx') seed =
-    checkCoverage
-        $ forAll (dropResolvedInputs partialTx') $ \(partialTx, dropped) -> do
-            let res = balanceTransaction' wallet seed partialTx
-            cover 0.1 (isUnresolvedTxInsErr res) "unknown txins" $
-                case res of
-                    Right _
-                        | null dropped
-                            -> label "nothing dropped"
-                                $ property True
-                        | otherwise
-                            -> label "succeeded despite unresolved input"
-                                $ property True
-                            -- Balancing can succeed if the dropped inputs
-                            -- happen to be a part of the wallet UTxO.
-                    Left (ErrBalanceTxAssignRedeemers
-                        (ErrAssignRedeemersTranslationError
-                            (TranslationLogicMissingInput _)))
-                        -> property True
-                    Left _
-                        -> label "other error" $ property True
+prop_balanceTransactionUnresolvedInputs (ShowBuildable partialTx') seed =
+    -- checkCoverage
+    forAll (dropResolvedInputs partialTx') $ \(partialTx, dropped) -> do
+        let wallet = smallWallet
+        let res = balanceTransaction' wallet seed partialTx
+
+        let userSpecifiedInputs = Set.fromList $
+                map (\(i,_,_) -> i) $ view #inputs partialTx
+        let walletUTxOInputs =
+                let
+                    Wallet' _ w _ = wallet
+                in
+                    Set.fromList $ map fst $ UTxO.toList $ view #utxo w
+
+        let requiredInputs =
+                userSpecifiedInputs `Set.difference` walletUTxOInputs
+
+        cover 1 (isUnresolvedTxInsErr res) "unknown txins" $
+            case res of
+                Right _
+                    | null dropped
+                        -> label "nothing dropped"
+                            $ property True
+                    | otherwise
+                        -> label "succeeded despite unresolved input" $ do
+                            let droppedSet =
+                                    Set.fromList $ map (\(i,_,_) -> i) dropped
+                            property $
+                                (requiredInputs `Set.intersection` droppedSet)
+                                    === mempty
+                        -- Balancing can succeed if the dropped inputs
+                        -- happen to be a part of the wallet UTxO.
+                Left (ErrBalanceTxAssignRedeemers
+                    (ErrAssignRedeemersTranslationError
+                        (TranslationLogicMissingInput _)))
+                    -> property True
+                Left e
+                    -> counterexample (show e) $ property False
   where
     isUnresolvedTxInsErr
         (Left
@@ -3019,13 +3041,29 @@ prop_balanceTransactionUnresolvedInputs wallet (ShowBuildable partialTx') seed =
 
     dropResolvedInputs (PartialTx tx inputs redeemers) = do
         shouldKeep <- vectorOf (length inputs) $ frequency
-            [ (8, pure False)
-            , (2, pure True)
+            [ (9, pure False)
+            , (1, pure True)
             ]
         let inputs' = map snd $ filter        fst  $ zip shouldKeep inputs
         let dropped = map snd $ filter (not . fst) $ zip shouldKeep inputs
         pure (PartialTx tx inputs' redeemers, dropped)
 
+    -- A wallet with a single utxo for minimal overlap with user-specified
+    -- resolution, and lots of ada to make balancing succeed.
+    smallWallet = mkTestWallet rootK $ utxo [Coin 20_000_000_000_000]
+      where
+            utxo coins = UTxO $ Map.fromList $ zip ins outs
+              where
+                ins = map (TxIn dummyHash) [0..]
+                outs = map (TxOut addr . TokenBundle.fromCoin) coins
+                dummyHash = Hash $ B8.replicate 32 '0'
+
+            mw = SomeMnemonic $ either (error . show) id
+                (entropyToMnemonic @12 <$> mkEntropy "0000000000000000")
+            rootK = Shelley.unsafeGenerateKeyFromSeed (mw, Nothing) mempty
+            addr = Address $ unsafeFromHex
+                "60b1e5e0fb74c86c801f646841e07cdb42df8b82ef3ce4e57cb5412e77"
+
 prop_posAndNegFromCardanoValueRoundtrip :: Property
 prop_posAndNegFromCardanoValueRoundtrip = forAll genSignedValue $ \v ->
     let