Skip to content

Commit 303b86f

Browse files
SoupstrawSoupstraw
committed
WIP
1 parent 92ab64c commit 303b86f

File tree

10 files changed

+84
-59
lines changed

10 files changed

+84
-59
lines changed

‎eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs‎

Lines changed: 0 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
{-# LANGUAGE DataKinds #-}
2-
{-# LANGUAGE DefaultSignatures #-}
32
{-# LANGUAGE FlexibleContexts #-}
43
{-# LANGUAGE GADTs #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -70,7 +69,6 @@ import Cardano.Slotting.Time (SystemStart)
7069
import Control.DeepSeq (NFData)
7170
import Control.Monad.Trans.Fail.String (errorFail)
7271
import Data.Aeson (ToJSON)
73-
import Data.Coerce (Coercible, coerce)
7472
import Data.Kind (Type)
7573
import Data.List.NonEmpty (NonEmpty, nonEmpty)
7674
import Data.Text (Text)
@@ -95,52 +93,17 @@ class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language
9593
ProtVer ->
9694
TxCert era ->
9795
Either (ContextError era) (PlutusTxCert l)
98-
default toPlutusTxCert ::
99-
forall proxy.
100-
( Era era
101-
, EraPlutusTxInfo l (PreviousEra era)
102-
, Coercible (ContextError (PreviousEra era)) (ContextError era)
103-
, Coercible (TxCert era) (TxCert (PreviousEra era))
104-
) =>
105-
proxy l ->
106-
ProtVer ->
107-
TxCert era ->
108-
Either (ContextError era) (PlutusTxCert l)
109-
toPlutusTxCert = coerce $ toPlutusTxCert @l @(PreviousEra era) @proxy
11096

11197
toPlutusScriptPurpose ::
11298
proxy l ->
11399
ProtVer ->
114100
PlutusPurpose AsIxItem era ->
115101
Either (ContextError era) (PlutusScriptPurpose l)
116-
default toPlutusScriptPurpose ::
117-
forall proxy.
118-
( Era era
119-
, EraPlutusTxInfo l (PreviousEra era)
120-
, Coercible (ContextError (PreviousEra era)) (ContextError era)
121-
, Coercible (PlutusPurpose AsIxItem era) (PlutusPurpose AsIxItem (PreviousEra era))
122-
) =>
123-
proxy l ->
124-
ProtVer ->
125-
PlutusPurpose AsIxItem era ->
126-
Either (ContextError era) (PlutusScriptPurpose l)
127-
toPlutusScriptPurpose = coerce $ toPlutusScriptPurpose @l @(PreviousEra era) @proxy
128102

129103
toPlutusTxInfo ::
130104
proxy l ->
131105
LedgerTxInfo era ->
132106
Either (ContextError era) (PlutusTxInfo l)
133-
default toPlutusTxInfo ::
134-
forall proxy.
135-
( Era era
136-
, EraPlutusTxInfo l (PreviousEra era)
137-
, Coercible (ContextError (PreviousEra era)) (ContextError era)
138-
, Coercible (LedgerTxInfo era) (LedgerTxInfo (PreviousEra era))
139-
) =>
140-
proxy l ->
141-
LedgerTxInfo era ->
142-
Either (ContextError era) (PlutusTxInfo l)
143-
toPlutusTxInfo = coerce $ toPlutusTxInfo @l @(PreviousEra era) @proxy
144107

145108
toPlutusArgs ::
146109
proxy l ->
@@ -150,21 +113,6 @@ class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language
150113
Maybe (Data era) ->
151114
Data era ->
152115
Either (ContextError era) (PlutusArgs l)
153-
default toPlutusArgs ::
154-
forall proxy.
155-
( Era era
156-
, EraPlutusTxInfo l (PreviousEra era)
157-
, Coercible (ContextError (PreviousEra era)) (ContextError era)
158-
, Coercible (PlutusPurpose AsIxItem era) (PlutusPurpose AsIxItem (PreviousEra era))
159-
) =>
160-
proxy l ->
161-
ProtVer ->
162-
PlutusTxInfo l ->
163-
PlutusPurpose AsIxItem era ->
164-
Maybe (Data era) ->
165-
Data era ->
166-
Either (ContextError era) (PlutusArgs l)
167-
toPlutusArgs = coerce $ toPlutusArgs @l @(PreviousEra era) @proxy
168116

169117
class
170118
( AlonzoEraScript era

‎eras/dijkstra/cardano-ledger-dijkstra.cabal‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -104,8 +104,10 @@ library testlib
104104
hs-source-dirs: testlib
105105
exposed-modules:
106106
Test.Cardano.Ledger.Dijkstra.Arbitrary
107+
Test.Cardano.Ledger.Dijkstra.Binary.Annotator
107108
Test.Cardano.Ledger.Dijkstra.Era
108109
Test.Cardano.Ledger.Dijkstra.ImpTest
110+
Test.Cardano.Ledger.Dijkstra.TreeDiff
109111
other-modules: Paths_cardano_ledger_dijkstra
110112
default-language: Haskell2010
111113
ghc-options:
@@ -120,7 +122,9 @@ library testlib
120122
build-depends:
121123
base,
122124
cardano-ledger-core:{cardano-ledger-core, testlib},
123-
cardano-ledger-conway:testlib,
125+
cardano-ledger-binary,
126+
cardano-ledger-shelley,
127+
cardano-ledger-conway:{cardano-ledger-conway, testlib},
124128
cardano-ledger-dijkstra,
125129

126130
test-suite tests
@@ -145,9 +149,7 @@ test-suite tests
145149

146150
build-depends:
147151
base,
148-
cardano-ledger-allegra,
149-
cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
152+
cardano-ledger-alonzo:testlib,
150153
cardano-ledger-conway:testlib,
151154
cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib},
152-
cardano-ledger-core:{cardano-ledger-core, testlib},
153-
cardano-ledger-binary:testlib,
155+
cardano-ledger-core:testlib,

‎eras/dijkstra/src/Cardano/Ledger/Dijkstra/Rules/Deleg.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1 +1,16 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE TypeFamilies #-}
4+
{-# OPTIONS_GHC -Wno-orphans #-}
5+
16
module Cardano.Ledger.Dijkstra.Rules.Deleg () where
7+
8+
import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure)
9+
import Cardano.Ledger.Dijkstra.Core
10+
import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
11+
12+
type instance EraRuleFailure "DELEG" DijkstraEra = ConwayDelegPredFailure DijkstraEra
13+
14+
type instance EraRuleEvent "DELEG" DijkstraEra = VoidEraRule "DELEG" DijkstraEra
15+
16+
instance InjectRuleFailure "DELEG" ConwayDelegPredFailure DijkstraEra

‎eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
{-# LANGUAGE LambdaCase #-}
66
{-# LANGUAGE TypeFamilies #-}
77
{-# OPTIONS_GHC -Wno-orphans #-}
8+
{-# LANGUAGE UndecidableInstances #-}
89

910
module Cardano.Ledger.Dijkstra.Scripts (PlutusScript (..)) where
1011

@@ -41,6 +42,7 @@ import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..))
4142
import Control.DeepSeq (NFData)
4243
import Data.MemPack (MemPack (..))
4344
import NoThunks.Class (NoThunks)
45+
import GHC.Generics (Generic)
4446

4547
instance EraScript DijkstraEra where
4648
type Script DijkstraEra = AlonzoScript DijkstraEra
@@ -63,7 +65,7 @@ instance MemPack (PlutusScript DijkstraEra) where
6365
instance AlonzoEraScript DijkstraEra where
6466
newtype PlutusScript DijkstraEra = MkDijkstraPlutusScript
6567
{unDijkstraPlutusScript :: PlutusScript ConwayEra}
66-
deriving newtype (SafeToHash, Show, NFData, NoThunks, Eq, Ord)
68+
deriving newtype (SafeToHash, Show, NFData, NoThunks, Eq, Ord, Generic)
6769

6870
type PlutusPurpose f DijkstraEra = ConwayPlutusPurpose f DijkstraEra
6971

‎eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ module Cardano.Ledger.Dijkstra.TxBody (
3636
dtbCurrentTreasuryValue,
3737
dtbTreasuryDonation
3838
),
39+
DijkstraTxBodyRaw (..),
3940
) where
4041

4142
import Cardano.Ledger.Babbage.TxBody (

‎eras/dijkstra/test/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
module Main where
44

55
import Cardano.Ledger.Dijkstra (DijkstraEra)
6+
import Cardano.Ledger.Dijkstra.Rules ()
67
import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec
78
import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec
89
import Test.Cardano.Ledger.Common
@@ -20,6 +21,7 @@ import qualified Test.Cardano.Ledger.Conway.Proposals as Proposals
2021
import qualified Test.Cardano.Ledger.Conway.SPORatifySpec as SPORatifySpec
2122
import qualified Test.Cardano.Ledger.Conway.TxInfoSpec as TxInfo
2223
import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec)
24+
import Test.Cardano.Ledger.Dijkstra.Binary.Annotator ()
2325
import Test.Cardano.Ledger.Dijkstra.ImpTest ()
2426

2527
main :: IO ()

‎eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
{-# LANGUAGE DerivingVia #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE StandaloneDeriving #-}
4+
{-# OPTIONS_GHC -Wno-orphans #-}
5+
6+
module Test.Cardano.Ledger.Dijkstra.Binary.Annotator (
7+
module Test.Cardano.Ledger.Conway.Binary.Annotator,
8+
) where
9+
10+
import Cardano.Ledger.Binary (Annotator, DecCBOR (..))
11+
import Cardano.Ledger.Dijkstra (DijkstraEra)
12+
import Cardano.Ledger.Dijkstra.Core
13+
import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw, TxBody (MkDijkstraTxBody))
14+
import Test.Cardano.Ledger.Conway.Binary.Annotator (Mem)
15+
16+
instance DecCBOR (Annotator DijkstraTxBodyRaw) where
17+
decCBOR = pure <$> decCBOR
18+
19+
deriving via Mem DijkstraTxBodyRaw instance DecCBOR (Annotator (TxBody DijkstraEra))

‎eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Era.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@
22
module Test.Cardano.Ledger.Dijkstra.Era () where
33

44
import Cardano.Ledger.Dijkstra (DijkstraEra)
5+
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()
6+
import Test.Cardano.Ledger.Dijkstra.TreeDiff ()
57
import Test.Cardano.Ledger.Conway.Era (
68
AllegraEraTest,
79
AlonzoEraTest,

‎eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/ImpTest.hs‎

Lines changed: 20 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,18 @@
11
{-# LANGUAGE TypeFamilies #-}
22
{-# OPTIONS_GHC -Wno-orphans #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE MultiParamTypeClasses #-}
35

46
module Test.Cardano.Ledger.Dijkstra.ImpTest () where
57

68
import Cardano.Ledger.Dijkstra (DijkstraEra)
7-
import Test.Cardano.Ledger.Dijkstra.Era
9+
import Test.Cardano.Ledger.Dijkstra.Era ()
810
import Cardano.Ledger.Plutus (SLanguage (..))
911
import Test.Cardano.Ledger.Conway.ImpTest
12+
import Cardano.Ledger.Dijkstra.Core
13+
import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
14+
import qualified Cardano.Ledger.Shelley.Rules as Shelley
15+
import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure(..), ConwayLedgerPredFailure (..), ConwayCertsPredFailure (..), ConwayCertPredFailure (..))
1016

1117
instance ShelleyEraImp DijkstraEra where
1218
initGenesis = pure ()
@@ -27,3 +33,16 @@ instance AlonzoEraImp DijkstraEra where
2733
<> plutusTestScripts SPlutusV3
2834

2935
instance ConwayEraImp DijkstraEra
36+
37+
-- Partial implementation used for checking predicate failures
38+
instance InjectRuleFailure "LEDGER" ShelleyDelegPredFailure DijkstraEra where
39+
injectFailure = ConwayCertsFailure . injectFailure
40+
instance InjectRuleFailure "CERTS" ShelleyDelegPredFailure DijkstraEra where
41+
injectFailure = CertFailure . injectFailure
42+
instance InjectRuleFailure "CERT" ShelleyDelegPredFailure DijkstraEra where
43+
injectFailure = DelegFailure . injectFailure
44+
instance InjectRuleFailure "DELEG" ShelleyDelegPredFailure DijkstraEra where
45+
injectFailure (Shelley.StakeKeyAlreadyRegisteredDELEG c) = StakeKeyRegisteredDELEG c
46+
injectFailure (Shelley.StakeKeyNotRegisteredDELEG c) = StakeKeyNotRegisteredDELEG c
47+
injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG c) = StakeKeyHasNonZeroRewardAccountBalanceDELEG c
48+
injectFailure _ = error "Cannot inject ShelleyDelegPredFailure into DijkstraEra"

‎eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Test.Cardano.Ledger.Dijkstra.TreeDiff () where
5+
6+
import Cardano.Ledger.Dijkstra (DijkstraEra)
7+
import Cardano.Ledger.Dijkstra.Core (EraTxBody (..), PlutusScript)
8+
import Cardano.Ledger.Dijkstra.TxBody (DijkstraTxBodyRaw)
9+
import Test.Cardano.Ledger.Conway.TreeDiff (ToExpr)
10+
11+
instance ToExpr (PlutusScript DijkstraEra)
12+
13+
instance ToExpr DijkstraTxBodyRaw
14+
15+
instance ToExpr (TxBody DijkstraEra)

0 commit comments

Comments
 (0)