module Test.Cardano.Ledger.Generic.PrettyTest (testwidth, prettyTest) where

import Cardano.Ledger.Core (Tx, TxBody)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState (LedgerState)
import Cardano.Ledger.State (UTxO)
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
import Prettyprinter.Util (putDocW)
import Test.Cardano.Ledger.Generic.PrettyCore
import Test.Cardano.Ledger.Generic.Proof (Proof (Shelley))
import Test.Cardano.Ledger.Shelley.Arbitrary ()
import Test.Cardano.Ledger.Shelley.Serialisation.Generators ()
import Test.Tasty
import Test.Tasty.QuickCheck (Arbitrary (..), Gen, generate, testProperty, withMaxSuccess, (===))

-- ====================================================
-- a few generators to generate random UTxO, TxBody, Tx and LedgerState

txbody :: Gen (TxBody ShelleyEra)
txbody :: Gen (TxBody ShelleyEra)
txbody = Gen (TxBody ShelleyEra)
forall a. Arbitrary a => Gen a
arbitrary

tx :: Gen (Tx ShelleyEra)
tx :: Gen (Tx ShelleyEra)
tx = Gen (Tx ShelleyEra)
Gen (ShelleyTx ShelleyEra)
forall a. Arbitrary a => Gen a
arbitrary

utxo :: Gen (UTxO ShelleyEra)
utxo :: Gen (UTxO ShelleyEra)
utxo = Gen (UTxO ShelleyEra)
forall a. Arbitrary a => Gen a
arbitrary

ls :: Gen (LedgerState ShelleyEra)
ls :: Gen (LedgerState ShelleyEra)
ls = Gen (LedgerState ShelleyEra)
forall a. Arbitrary a => Gen a
arbitrary

-- | Used to test pretty printing things with different widths
--   for example: testwidth 120 ls ppLedgerState
--   prints a random LedgerState with a max width of 120 columns
--   one can use this to observe the how "pretty" a printer is at different widths
testwidth :: Int -> Gen a -> (a -> PDoc) -> IO ()
testwidth :: forall a. Int -> Gen a -> (a -> PDoc) -> IO ()
testwidth Int
n Gen a
gen a -> PDoc
pp = do
  a
b <- Gen a -> IO a
forall a. Gen a -> IO a
generate Gen a
gen
  let doc :: PDoc
doc = a -> PDoc
pp a
b
  Int -> PDoc -> IO ()
forall ann. Int -> Doc ann -> IO ()
putDocW Int
n PDoc
doc
  String -> IO ()
putStrLn String
""

-- | The idea is to see that the pretty printer actually produces some output
testPP :: String -> (t -> PDoc) -> Gen t -> TestTree
testPP :: forall t. String -> (t -> PDoc) -> Gen t -> TestTree
testPP String
name t -> PDoc
ppT Gen t
gen = String -> Gen Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
name (do t
t <- Gen t
gen; Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Property -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
25 (PDoc -> Text
forall {ann}. Doc ann -> Text
toText (t -> PDoc
ppT t
t) Text -> Text -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PDoc -> Text
forall {ann}. Doc ann -> Text
toText (t -> PDoc
ppT t
t))))
  where
    toText :: Doc ann -> Text
toText Doc ann
doc = SimpleDocStream ann -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc ann
doc)

prettyTest :: TestTree
prettyTest :: TestTree
prettyTest =
  String -> [TestTree] -> TestTree
testGroup
    String
"Pretty printer tests"
    [ String
-> (UTxO ShelleyEra -> PDoc) -> Gen (UTxO ShelleyEra) -> TestTree
forall t. String -> (t -> PDoc) -> Gen t -> TestTree
testPP String
"UTxO" (Proof ShelleyEra -> UTxO ShelleyEra -> PDoc
forall era. Proof era -> UTxO era -> PDoc
pcUTxO Proof ShelleyEra
proof) Gen (UTxO ShelleyEra)
utxo
    , String
-> (TxBody ShelleyEra -> PDoc)
-> Gen (TxBody ShelleyEra)
-> TestTree
forall t. String -> (t -> PDoc) -> Gen t -> TestTree
testPP String
"TxBody" (Proof ShelleyEra -> TxBody ShelleyEra -> PDoc
forall era. Proof era -> TxBody era -> PDoc
pcTxBody Proof ShelleyEra
proof) Gen (TxBody ShelleyEra)
txbody
    , String
-> (ShelleyTx ShelleyEra -> PDoc)
-> Gen (ShelleyTx ShelleyEra)
-> TestTree
forall t. String -> (t -> PDoc) -> Gen t -> TestTree
testPP String
"Tx" (Proof ShelleyEra -> Tx ShelleyEra -> PDoc
forall era. Proof era -> Tx era -> PDoc
pcTx Proof ShelleyEra
proof) Gen (Tx ShelleyEra)
Gen (ShelleyTx ShelleyEra)
tx
    , String
-> (LedgerState ShelleyEra -> PDoc)
-> Gen (LedgerState ShelleyEra)
-> TestTree
forall t. String -> (t -> PDoc) -> Gen t -> TestTree
testPP String
"LedgerState" (Proof ShelleyEra -> LedgerState ShelleyEra -> PDoc
forall era. Reflect era => Proof era -> LedgerState era -> PDoc
pcLedgerState Proof ShelleyEra
proof) Gen (LedgerState ShelleyEra)
ls
    ]
  where
    proof :: Proof ShelleyEra
proof = Proof ShelleyEra
Shelley