Skip to content

Commit c23dc0e

Browse files
carlostomecarlostome
committed
Refactor Spec.Conway into Spec.Core
1 parent 3888702 commit c23dc0e

File tree

3 files changed

+98
-84
lines changed

3 files changed

+98
-84
lines changed

‎libs/cardano-ledger-conformance/cardano-ledger-conformance.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -114,6 +114,7 @@ test-suite tests
114114
Test.Cardano.Ledger.Conformance.Imp.Core
115115
Test.Cardano.Ledger.Conformance.Spec.Base
116116
Test.Cardano.Ledger.Conformance.Spec.Conway
117+
Test.Cardano.Ledger.Conformance.Spec.Core
117118

118119
default-language: Haskell2010
119120
ghc-options:

‎libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Spec/Conway.hs‎

Lines changed: 2 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -8,23 +8,12 @@
88
{-# LANGUAGE TupleSections #-}
99
{-# LANGUAGE TypeApplications #-}
1010

11-
module Test.Cardano.Ledger.Conformance.Spec.Conway (
12-
spec,
13-
genFromBundle,
14-
genFromBundle_,
15-
) where
11+
module Test.Cardano.Ledger.Conformance.Spec.Conway ( spec ) where
1612

17-
import Cardano.Ledger.Core (EraRule)
18-
import Constrained.API
19-
import Control.Monad.Cont (ContT (..))
20-
import Control.Monad.Trans (MonadTrans (..))
21-
import Control.State.Transition.Extended (STS (..), TRC (..))
2213
import Data.Map.Strict qualified as Map
23-
import Test.Cardano.Ledger.Conformance (ExecSpecRule (..), ForAllExecTypes, testConformance)
2414
import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway (ConwayCertExecContext (..))
2515
import Test.Cardano.Ledger.Constrained.Conway (genUtxoExecContext)
2616
import Test.Cardano.Ledger.Constrained.Conway.MiniTrace (
27-
ConstrainedGeneratorBundle (..),
2817
ConwayCertGenContext (..),
2918
constrainedCert,
3019
constrainedCerts,
@@ -37,79 +26,8 @@ import Test.Cardano.Ledger.Constrained.Conway.MiniTrace (
3726
constrainedRatify,
3827
constrainedUtxo,
3928
)
40-
import Test.Cardano.Ledger.Conway.ImpTest (ImpTestM, impAnn)
4129
import Test.Cardano.Ledger.Imp.Common
42-
import UnliftIO (MonadIO (..), evaluateDeep)
43-
44-
conformsToImpl ::
45-
forall rule era.
46-
ExecSpecRule rule era =>
47-
Gen (ExecContext rule era, TRC (EraRule rule era)) ->
48-
Property
49-
conformsToImpl genInputs = property @(ImpTestM era Property) . (`runContT` pure) $ do
50-
let
51-
deepEvalAnn s = "Deep evaluating " <> s
52-
deepEval x s = do
53-
_ <- lift $ impAnn (deepEvalAnn s) (liftIO (evaluateDeep x))
54-
pure ()
55-
(ctx, trc@(TRC (env, st, sig))) <- lift $ liftGen genInputs
56-
deepEval ctx "context"
57-
deepEval env "environment"
58-
deepEval st "state"
59-
deepEval sig "signal"
60-
pure $ testConformance @rule @era ctx trc
61-
62-
genFromBundle_ ::
63-
( HasSpec (Environment (EraRule rule era))
64-
, HasSpec (State (EraRule rule era))
65-
, HasSpec (Signal (EraRule rule era))
66-
, Arbitrary (ExecContext rule era)
67-
) =>
68-
ConstrainedGeneratorBundle ctx rule era ->
69-
Gen (ExecContext rule era, TRC (EraRule rule era))
70-
genFromBundle_ x = genFromBundle x $ \_ _ _ _ -> arbitrary
71-
72-
genFromBundle ::
73-
ForAllExecTypes HasSpec rule era =>
74-
ConstrainedGeneratorBundle ctx rule era ->
75-
( ctx ->
76-
Environment (EraRule rule era) ->
77-
State (EraRule rule era) ->
78-
Signal (EraRule rule era) ->
79-
Gen (ExecContext rule era)
80-
) ->
81-
Gen (ExecContext rule era, TRC (EraRule rule era))
82-
genFromBundle ConstrainedGeneratorBundle {..} genExecContext = do
83-
ctx <- cgbContextGen
84-
env <- genFromSpec $ cgbEnvironmentSpec ctx
85-
st <- genFromSpec $ cgbStateSpec ctx env
86-
sig <- genFromSpec $ cgbSignalSpec ctx env st
87-
(,TRC (env, st, sig)) <$> genExecContext ctx env st sig
88-
89-
conformsToImplConstrained ::
90-
forall ctx rule era.
91-
( ExecSpecRule rule era
92-
, ForAllExecTypes HasSpec rule era
93-
) =>
94-
ConstrainedGeneratorBundle ctx rule era ->
95-
( ctx ->
96-
Environment (EraRule rule era) ->
97-
State (EraRule rule era) ->
98-
Signal (EraRule rule era) ->
99-
Gen (ExecContext rule era)
100-
) ->
101-
Property
102-
conformsToImplConstrained bundle genExecContext =
103-
conformsToImpl @rule @era $ genFromBundle bundle genExecContext
104-
105-
conformsToImplConstrained_ ::
106-
( ExecSpecRule rule era
107-
, ForAllExecTypes HasSpec rule era
108-
, Arbitrary (ExecContext rule era)
109-
) =>
110-
ConstrainedGeneratorBundle ctx rule era ->
111-
Property
112-
conformsToImplConstrained_ bundle = conformsToImplConstrained bundle $ \_ _ _ _ -> arbitrary
30+
import Test.Cardano.Ledger.Conformance.Spec.Core
11331

11432
spec :: Spec
11533
spec = do

‎libs/cardano-ledger-conformance/test/Test/Cardano/Ledger/Conformance/Spec/Core.hs‎

Lines changed: 95 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,95 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE ImportQualifiedPost #-}
5+
{-# LANGUAGE RankNTypes #-}
6+
{-# LANGUAGE RecordWildCards #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE TupleSections #-}
9+
{-# LANGUAGE TypeApplications #-}
10+
11+
module Test.Cardano.Ledger.Conformance.Spec.Core where
12+
13+
import Cardano.Ledger.Core (EraRule)
14+
import Constrained.API
15+
import Control.Monad.Cont (ContT (..))
16+
import Control.Monad.Trans (MonadTrans (..))
17+
import Control.State.Transition.Extended (STS (..), TRC (..))
18+
import Test.Cardano.Ledger.Conformance (ExecSpecRule (..), ForAllExecTypes, testConformance)
19+
import Test.Cardano.Ledger.Constrained.Conway.MiniTrace (
20+
ConstrainedGeneratorBundle (..),
21+
)
22+
import Test.Cardano.Ledger.Conway.ImpTest (ImpTestM, impAnn)
23+
import Test.Cardano.Ledger.Imp.Common
24+
import UnliftIO (MonadIO (..), evaluateDeep)
25+
26+
conformsToImpl ::
27+
forall rule era.
28+
ExecSpecRule rule era =>
29+
Gen (ExecContext rule era, TRC (EraRule rule era)) ->
30+
Property
31+
conformsToImpl genInputs = property @(ImpTestM era Property) . (`runContT` pure) $ do
32+
let
33+
deepEvalAnn s = "Deep evaluating " <> s
34+
deepEval x s = do
35+
_ <- lift $ impAnn (deepEvalAnn s) (liftIO (evaluateDeep x))
36+
pure ()
37+
(ctx, trc@(TRC (env, st, sig))) <- lift $ liftGen genInputs
38+
deepEval ctx "context"
39+
deepEval env "environment"
40+
deepEval st "state"
41+
deepEval sig "signal"
42+
pure $ testConformance @rule @era ctx trc
43+
44+
genFromBundle_ ::
45+
( HasSpec (Environment (EraRule rule era))
46+
, HasSpec (State (EraRule rule era))
47+
, HasSpec (Signal (EraRule rule era))
48+
, Arbitrary (ExecContext rule era)
49+
) =>
50+
ConstrainedGeneratorBundle ctx rule era ->
51+
Gen (ExecContext rule era, TRC (EraRule rule era))
52+
genFromBundle_ x = genFromBundle x $ \_ _ _ _ -> arbitrary
53+
54+
genFromBundle ::
55+
ForAllExecTypes HasSpec rule era =>
56+
ConstrainedGeneratorBundle ctx rule era ->
57+
( ctx ->
58+
Environment (EraRule rule era) ->
59+
State (EraRule rule era) ->
60+
Signal (EraRule rule era) ->
61+
Gen (ExecContext rule era)
62+
) ->
63+
Gen (ExecContext rule era, TRC (EraRule rule era))
64+
genFromBundle ConstrainedGeneratorBundle {..} genExecContext = do
65+
ctx <- cgbContextGen
66+
env <- genFromSpec $ cgbEnvironmentSpec ctx
67+
st <- genFromSpec $ cgbStateSpec ctx env
68+
sig <- genFromSpec $ cgbSignalSpec ctx env st
69+
(,TRC (env, st, sig)) <$> genExecContext ctx env st sig
70+
71+
conformsToImplConstrained ::
72+
forall ctx rule era.
73+
( ExecSpecRule rule era
74+
, ForAllExecTypes HasSpec rule era
75+
) =>
76+
ConstrainedGeneratorBundle ctx rule era ->
77+
( ctx ->
78+
Environment (EraRule rule era) ->
79+
State (EraRule rule era) ->
80+
Signal (EraRule rule era) ->
81+
Gen (ExecContext rule era)
82+
) ->
83+
Property
84+
conformsToImplConstrained bundle genExecContext =
85+
conformsToImpl @rule @era $ genFromBundle bundle genExecContext
86+
87+
conformsToImplConstrained_ ::
88+
( ExecSpecRule rule era
89+
, ForAllExecTypes HasSpec rule era
90+
, Arbitrary (ExecContext rule era)
91+
) =>
92+
ConstrainedGeneratorBundle ctx rule era ->
93+
Property
94+
conformsToImplConstrained_ bundle = conformsToImplConstrained bundle $ \_ _ _ _ -> arbitrary
95+

0 commit comments

Comments
 (0)