wip

Author: Lucsanszky

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/CertState.hs

@@ -16,6 +16,7 @@ import Cardano.Ledger.Shelley.LedgerState (availableAfterMIR)
 import Cardano.Ledger.Shelley.TxCert (MIRPot (..))
 import Control.Monad (when)
 import Data.Default (Default (def))
+import Data.TreeDiff (toExpr)
 import Lens.Micro
 import Test.Cardano.Ledger.Constrained.Ast
 import Test.Cardano.Ledger.Constrained.Classes (OrdCond (..), unCertStateF)
@@ -31,8 +32,10 @@ import Test.Cardano.Ledger.Constrained.Solver
 import Test.Cardano.Ledger.Constrained.TypeRep
 import Test.Cardano.Ledger.Constrained.Utils (testIO)
 import Test.Cardano.Ledger.Constrained.Vars
+import Test.Cardano.Ledger.Conway.TreeDiff ()
 import Test.Cardano.Ledger.Generic.Functions (protocolVersion)
 import Test.Cardano.Ledger.Generic.Proof
+import Test.Cardano.Ledger.TreeDiff ()
 import Test.QuickCheck
 import Test.Tasty (TestTree, defaultMain, testGroup)
 
@@ -91,13 +94,13 @@ vstateCheckPreds :: Proof era -> [Pred era]
 vstateCheckPreds _p = []
 
 vstateStage ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   Proof era ->
   Subst era ->
   Gen (Subst era)
 vstateStage proof = toolChainSub proof standardOrderInfo (vstatePreds proof)
 
-demoV :: ReplMode -> IO ()
+demoV :: ToExprs ConwayEra => ReplMode -> IO ()
 demoV mode = do
   let proof = Conway
   env <-
@@ -109,13 +112,13 @@ demoV mode = do
           >>= (\subst -> monadTyped $ substToEnv subst emptyEnv)
       )
   vstate <- monadTyped $ runTarget env vstateT
-  when (mode == Interactive) $ putStrLn (show (pcVState vstate))
+  when (mode == Interactive) . print $ toExpr vstate
   modeRepl mode proof env ""
 
-demoTestV :: TestTree
+demoTestV :: ToExprs ConwayEra => TestTree
 demoTestV = testIO "Testing VState Stage" (demoV CI)
 
-mainV :: IO ()
+mainV :: ToExprs ConwayEra => IO ()
 mainV = defaultMain $ testIO "Testing VState Stage" (demoV Interactive)
 
 -- ==========================================
@@ -162,13 +165,13 @@ pstateCheckPreds _ =
   ]
 
 pstateStage ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   Proof era ->
   Subst era ->
   Gen (Subst era)
 pstateStage proof = toolChainSub proof standardOrderInfo (pstatePreds proof)
 
-demoP :: ReplMode -> IO ()
+demoP :: ToExprs BabbageEra => ReplMode -> IO ()
 demoP mode = do
   let proof = Babbage
   env <-
@@ -179,14 +182,13 @@ demoP mode = do
           >>= (\subst -> monadTyped $ substToEnv subst emptyEnv)
       )
   pstate <- monadTyped $ runTarget env pstateT
-  when (mode == Interactive) $ do
-    putStrLn (show (pcPState pstate))
+  when (mode == Interactive) . print $ toExpr pstate
   modeRepl mode proof env ""
 
-demoTestP :: TestTree
+demoTestP :: ToExprs BabbageEra => TestTree
 demoTestP = testIO "Testing PState Stage" (demoP CI)
 
-mainP :: IO ()
+mainP :: ToExprs BabbageEra => IO ()
 mainP = defaultMain $ testIO "Testing PState Stage" (demoP Interactive)
 
 -- =================================================
@@ -303,13 +305,13 @@ certStateCheckPreds p =
   ]
 
 dstateStage ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   Proof era ->
   Subst era ->
   Gen (Subst era)
 dstateStage proof = toolChainSub proof standardOrderInfo (certStatePreds proof)
 
-demoD :: ReplMode -> Int -> IO ()
+demoD :: ToExprs BabbageEra => ReplMode -> Int -> IO ()
 demoD mode seed = do
   let proof = Babbage
   env <-
@@ -321,18 +323,18 @@ demoD mode seed = do
           >>= (\subst -> monadTyped $ substToEnv subst emptyEnv)
       )
   dState <- monadTyped $ runTarget env dstateT
-  when (mode == Interactive) $ putStrLn (show (pcDState dState))
+  when (mode == Interactive) . print $ toExpr dState
   modeRepl mode proof env ""
 
-demoTestD :: TestTree
+demoTestD :: ToExprs BabbageEra => TestTree
 demoTestD = testIO "Testing DState Stage" (demoD CI 99)
 
-mainD :: Int -> IO ()
+mainD :: ToExprs BabbageEra => Int -> IO ()
 mainD seed = defaultMain $ testIO "Testing DState Stage" (demoD Interactive seed)
 
 -- ===============================================
 
-demoC :: ReplMode -> IO ()
+demoC :: ToExprs ConwayEra => ReplMode -> IO ()
 demoC mode = do
   let proof = Conway
   env <-
@@ -346,16 +348,16 @@ demoC mode = do
           >>= (\subst -> monadTyped $ substToEnv subst emptyEnv)
       )
   certState <- monadTyped . runTarget env $ certStateT
-  when (mode == Interactive) $ putStrLn (show (pcCertState (unCertStateF certState)))
+  when (mode == Interactive) . print . toExpr $ unCertStateF certState
   modeRepl mode proof env ""
 
-demoTestC :: TestTree
+demoTestC :: ToExprs ConwayEra => TestTree
 demoTestC = testIO "Testing CertState Stage" (demoC CI)
 
-mainC :: IO ()
+mainC :: ToExprs ConwayEra => IO ()
 mainC = defaultMain $ testIO "Testing CertState Stage" (demoC Interactive)
 
-demoTest :: TestTree
+demoTest :: (ToExprs ConwayEra, ToExprs BabbageEra) => TestTree
 demoTest =
   testGroup
     "CertState tests"

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/LedgerState.hs

@@ -48,6 +48,7 @@ import qualified Data.OMap.Strict as OMap
 import Data.Ratio ((%))
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.TreeDiff (toExpr)
 import Lens.Micro
 import Test.Cardano.Ledger.Constrained.Ast
 import Test.Cardano.Ledger.Constrained.Classes (OrdCond (..), genPParamsUpdate)
@@ -102,7 +103,7 @@ enactStateCheckPreds _ = []
 
 ledgerStatePreds ::
   forall era.
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   UnivSize -> Proof era -> [Pred era]
 ledgerStatePreds _usize p =
   [ Subset (Dom enactWithdrawals) credsUniv
@@ -181,7 +182,7 @@ ledgerStatePreds _usize p =
     getOne [] = NoPParamsUpdate
 
 ledgerStateStage ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   UnivSize ->
   Proof era ->
   Subst era ->
@@ -195,7 +196,7 @@ ledgerStateStage usize proof subst0 = do
     Just msg -> error msg
 
 demo ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   Proof era -> ReplMode -> IO ()
 demo proof mode = do
   env <-
@@ -212,13 +213,13 @@ demo proof mode = do
       )
   lstate <- monadTyped $ runTarget env (ledgerStateT proof)
   let env2 = getTarget lstate (ledgerStateT proof) env
-  when (mode == Interactive) $ putStrLn (show (pcLedgerState proof lstate))
+  when (mode == Interactive) . print $ toExpr lstate
   modeRepl mode proof env2 ""
 
-demoTest :: TestTree
+demoTest :: ToExprs ConwayEra => TestTree
 demoTest = testIO "Testing LedgerState Stage" (demo Conway CI)
 
-main :: IO ()
+main :: ToExprs ConwayEra => IO ()
 main = defaultMain $ testIO "Testing LedgerState Stage" (demo Conway Interactive)
 
 -- =============================================
@@ -341,7 +342,7 @@ toProposalMap xs = Map.fromList (map pairup xs)
   where
     pairup gas = (gasId gas, gas)
 
-demoGov :: (ConwayEraPParams era, Reflect era) => Proof era -> ReplMode -> IO ()
+demoGov :: (ConwayEraPParams era, Reflect era, ToExprs era) => Proof era -> ReplMode -> IO ()
 demoGov proof mode = do
   env <-
     generate
@@ -353,7 +354,7 @@ demoGov proof mode = do
       )
   modeRepl mode proof env ""
 
-mainGov :: IO ()
+mainGov :: ToExprs ConwayEra => IO ()
 mainGov = demoGov Conway Interactive
 
 setActionId :: GovAction era -> Maybe GovActionId -> GovAction era

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/PParams.hs

@@ -39,7 +39,7 @@ import Test.Cardano.Ledger.Generic.Updaters (defaultCostModels, newPParams)
 import Test.Tasty (TestTree, defaultMain)
 import Test.Tasty.QuickCheck
 
-extract :: Era era => Term era t -> Term era s -> Pred era
+extract :: (Era era, ToExprs era) => Term era t -> Term era s -> Pred era
 extract term@(Var (V _ _ (Yes r1 lens))) record =
   case testEql r1 (termRep record) of
     Just Refl -> term :<-: (Constr "lookup" (\x -> x ^. lens) ^$ record)
@@ -99,7 +99,7 @@ genPParams proof tx bb bh = do
           ]
     )
 
-pParamsPreds :: Reflect era => Proof era -> [Pred era]
+pParamsPreds :: (Reflect era, ToExprs era) => Proof era -> [Pred era]
 pParamsPreds p =
   [ GenFrom
       (pparams p)
@@ -139,22 +139,22 @@ pParamsPreds p =
        )
 
 pParamsStage ::
-  Reflect era =>
+  (Reflect era, ToExprs era) =>
   Proof era ->
   Subst era ->
   Gen (Subst era)
 pParamsStage proof = toolChainSub proof standardOrderInfo (pParamsPreds proof)
 
-demo :: ReplMode -> IO ()
+demo :: ToExprs BabbageEra => ReplMode -> IO ()
 demo mode = do
   let proof = Babbage
   subst <- generate (pParamsStage proof emptySubst)
   env <- monadTyped (substToEnv subst emptyEnv)
   when (mode == Interactive) $ putStrLn "\n" >> putStrLn (show subst)
   modeRepl mode proof env ""
 
-demoTest :: TestTree
+demoTest :: ToExprs BabbageEra => TestTree
 demoTest = testIO "Testing TxOut Stage" (demo CI)
 
-mainPParams :: IO ()
+mainPParams :: ToExprs BabbageEra => IO ()
 mainPParams = defaultMain $ testIO "Testing TxOut Stage" (demo Interactive)