-
Notifications
You must be signed in to change notification settings - Fork 155
/
Core.hs
134 lines (123 loc) · 4.65 KB
/
Core.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Test.Cardano.Ledger.Conformance.ExecSpecRule.Core (
ExecSpecRule (..),
conformsToImpl,
computationResultToEither,
) where
import Cardano.Ledger.BaseTypes (Inject, ShelleyBase)
import Cardano.Ledger.Core (EraRule)
import qualified Constrained as CV2
import Constrained.Base (Specification (..))
import Control.State.Transition.Extended (STS (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bitraversable (bimapM)
import Data.Typeable (Typeable)
import GHC.Base (Constraint, NonEmpty, Symbol, Type)
import GHC.TypeLits (KnownSymbol)
import qualified Lib as Agda
import Test.Cardano.Ledger.Conformance.SpecTranslate.Core (SpecTranslate (..), runSpecTransM)
import Test.Cardano.Ledger.Imp.Common (
MonadGen (..),
NFData,
ToExpr,
expectRightExpr,
shouldBeExpr,
)
import Test.Cardano.Ledger.Shelley.ImpTest (
ImpTestM,
impAnn,
logEntry,
logToExpr,
tryRunImpRule,
)
type ForAllRuleTypes (c :: Type -> Constraint) rule era =
( c (Environment (EraRule rule era))
, c (State (EraRule rule era))
, c (Signal (EraRule rule era))
)
class
( ForAllRuleTypes (CV2.HasSpec fn) rule era
, ForAllRuleTypes (SpecTranslate (ExecContext fn rule era)) rule era
, ForAllRuleTypes ToExpr rule era
, ForAllRuleTypes NFData rule era
, CV2.HasSpec fn (ExecContext fn rule era)
, Inject (ExecContext fn rule era) (SpecTransContext (Environment (EraRule rule era)))
, Inject (ExecContext fn rule era) (SpecTransContext (State (EraRule rule era)))
, Inject (ExecContext fn rule era) (SpecTransContext (Signal (EraRule rule era)))
, Inject (ExecContext fn rule era) (SpecTransContext (PredicateFailure (EraRule rule era)))
, Eq (Event (EraRule rule era))
, Typeable (Event (EraRule rule era))
, KnownSymbol rule
, STS (EraRule rule era)
, BaseM (EraRule rule era) ~ ShelleyBase
, NFData (TestRep (PredicateFailure (EraRule rule era)))
, SpecTranslate (ExecContext fn rule era) (PredicateFailure (EraRule rule era))
) =>
ExecSpecRule fn (rule :: Symbol) era
where
type ExecContext fn rule era
type ExecContext fn rule era = ()
environmentSpec ::
CV2.Specification fn (Environment (EraRule rule era))
stateSpec ::
Environment (EraRule rule era) ->
CV2.Specification fn (State (EraRule rule era))
signalSpec ::
Environment (EraRule rule era) ->
State (EraRule rule era) ->
CV2.Specification fn (Signal (EraRule rule era))
execContextSpec :: CV2.Specification fn (ExecContext fn rule era)
default execContextSpec ::
ExecContext fn rule era ~ () =>
CV2.Specification fn (ExecContext fn rule era)
execContextSpec = TrueSpec
runAgdaRule ::
SpecRep (Environment (EraRule rule era)) ->
SpecRep (State (EraRule rule era)) ->
SpecRep (Signal (EraRule rule era)) ->
Either
(NonEmpty (SpecRep (PredicateFailure (EraRule rule era))))
(SpecRep (State (EraRule rule era)))
conformsToImpl ::
forall (rule :: Symbol) fn era.
( ExecSpecRule fn rule era
, NFData (SpecRep (PredicateFailure (EraRule rule era)))
, NFData (SpecRep (State (EraRule rule era)))
) =>
ImpTestM era ()
conformsToImpl = impAnn "conformsToImpl" . resize 5 $ do
env <- liftGen . CV2.genFromSpec_ $ environmentSpec @fn @rule @era
logToExpr env
st <- liftGen . CV2.genFromSpec_ $ stateSpec @fn @rule @era env
logToExpr st
sig <- liftGen . CV2.genFromSpec_ $ signalSpec @fn @rule @era env st
logToExpr sig
logEntry . show $ signalSpec @fn @rule @era env st
(execContext :: ctx) <- liftGen . CV2.genFromSpec_ $ execContextSpec @fn @rule @era
agdaRes <-
impAnn "Translating spec values to SpecRep" . expectRightExpr . runSpecTransM execContext $
runAgdaRule @fn @rule @era <$> toSpecRep env <*> toSpecRep st <*> toSpecRep sig
implRes <- fmap fst <$> tryRunImpRule @rule @era env st sig
implResTest <-
impAnn "Translating implementation values to SpecRep" . expectRightExpr . runSpecTransM execContext $
bimapM (traverse toTestRep) toTestRep implRes
let
agdaResTest =
bimap
(fmap $ specToTestRep @ctx @(PredicateFailure (EraRule rule era)))
(specToTestRep @ctx @(State (EraRule rule era)))
agdaRes
agdaResTest `shouldBeExpr` implResTest
computationResultToEither :: Agda.ComputationResult e a -> Either e a
computationResultToEither (Agda.Success x) = Right x
computationResultToEither (Agda.Failure e) = Left e