From c89ff0ee03843a4b91680013137b6260ba68e97b Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 9 Sep 2026 11:52:11 +0200 Subject: [PATCH 1/8] huge dependencies change --- cabal.project | 46 +++- .../cardano-node-emulator.cabal | 118 ++++----- cardano-node-emulator/package.yaml | 81 ++++++ .../Node/Emulator/Internal/Node/TimeSlot.hs | 3 +- .../cardano-node-socket-emulator.cabal | 168 ++++++------- cardano-node-socket-emulator/package.yaml | 99 ++++++++ dependency-summary-TO-BE-REMOVED.txt | 15 ++ flake.lock | 44 +--- flake.nix | 155 ++++++------ freer-extras/freer-extras.cabal | 112 ++++----- freer-extras/package.yaml | 69 ++++++ .../src/Control/Monad/Freer/Extras/Log.hs | 3 +- plutus-ledger/package.yaml | 133 ++++++++++ plutus-ledger/plutus-ledger.cabal | 233 ++++++++---------- plutus-ledger/src/Ledger/Tx.hs | 4 +- plutus-script-utils/package.yaml | 104 ++++++++ plutus-script-utils/plutus-script-utils.cabal | 174 ++++++------- .../src/Plutus/Script/Utils/V2/Typed.hs | 3 +- 18 files changed, 994 insertions(+), 570 deletions(-) create mode 100644 cardano-node-emulator/package.yaml create mode 100644 cardano-node-socket-emulator/package.yaml create mode 100644 dependency-summary-TO-BE-REMOVED.txt create mode 100644 freer-extras/package.yaml create mode 100644 plutus-ledger/package.yaml create mode 100644 plutus-script-utils/package.yaml diff --git a/cabal.project b/cabal.project index 1902cdb..ca340e9 100644 --- a/cabal.project +++ b/cabal.project @@ -12,8 +12,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2025-11-05T09:40:54Z - , cardano-haskell-packages 2025-12-16T19:03:49Z + , hackage.haskell.org 2026-09-04T06:57:08Z + , cardano-haskell-packages 2026-09-04T06:57:08Z packages: plutus-ledger plutus-script-utils @@ -22,14 +22,44 @@ packages: plutus-ledger freer-extras constraints: - cardano-api == 10.18.1.0 - + , cardano-api == 11.7.0.0 + +-- quickcheck-state-machine-0.10.2 still caps `random <1.3`, but +-- ouroboros-consensus (pulled in transitively) now requires +-- `random ^>=1.3`. quickcheck-state-machine works fine with random +-- 1.3 in practice; its bounds are just stale, so relax them here +-- instead of waiting for an upstream bump. +allow-newer: + , quickcheck-state-machine:random + -- We never, ever, want this. write-ghc-environment-files: never --- Always build tests and benchmarks. -tests: true -benchmarks: true +-- Only build tests and benchmarks for our own packages, not for +-- dependencies. Enabling tests/benchmarks globally forces cabal's +-- dependency solver to also satisfy the (often much stricter, and +-- sometimes conflicting) test-suite/benchmark dependency bounds of +-- every package in the plan, e.g. ouroboros-consensus's test-suites +-- pull in quickcheck-state-machine, which conflicts with the +-- `random` version required elsewhere. +tests: false +benchmarks: false + +package plutus-ledger + tests: true + benchmarks: true +package plutus-script-utils + tests: true + benchmarks: true +package cardano-node-emulator + tests: true + benchmarks: true +package cardano-node-socket-emulator + tests: true + benchmarks: true +package freer-extras + tests: true + benchmarks: true -- The only sensible test display option, since it allows us to have colourized -- 'tasty' output. @@ -41,7 +71,7 @@ test-show-details: direct -- For dev work we don't care about performance so much, so this is okay. package cardano-ledger-alonzo optimization: False -package ouroboros-consensus-cardano +package ouroboros-consensus optimization: False package cardano-api optimization: False diff --git a/cardano-node-emulator/cardano-node-emulator.cabal b/cardano-node-emulator/cardano-node-emulator.cabal index c5d7623..dd68c66 100644 --- a/cardano-node-emulator/cardano-node-emulator.cabal +++ b/cardano-node-emulator/cardano-node-emulator.cabal @@ -1,64 +1,46 @@ -cabal-version: 3.8 -name: cardano-node-emulator -version: 1.4.1.0 - -common lang - default-language: Haskell2010 - default-extensions: - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - ExplicitForAll - FlexibleContexts - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - NamedFieldPuns - ScopedTypeVariables - StandaloneDeriving +cabal-version: 3.0 - -- See Plutus Tx readme for why we need the following flags: - -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas - ghc-options: - -Wall -Widentities -Wincomplete-record-updates -Wunused-packages - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wredundant-constraints -Wmissing-import-lists -fobject-code - -fno-ignore-interface-pragmas -fno-omit-interface-pragmas - -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt - PlutusTx.Plugin:defer-errors +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False +name: cardano-node-emulator +version: 1.4.1.0 +build-type: Simple library - import: lang - hs-source-dirs: src exposed-modules: - Cardano.Node.Emulator - Cardano.Node.Emulator.API - Cardano.Node.Emulator.Generators - Cardano.Node.Emulator.Internal.API - Cardano.Node.Emulator.Internal.Node - Cardano.Node.Emulator.Internal.Node.Chain - Cardano.Node.Emulator.Internal.Node.Params - Cardano.Node.Emulator.Internal.Node.TimeSlot - Cardano.Node.Emulator.Internal.Node.Validation - Cardano.Node.Emulator.LogMessages - - -------------------- - -- Local components - -------------------- - build-depends: - , freer-extras - , plutus-ledger - - -------------------------- - -- Other IOG dependencies - -------------------------- + Cardano.Node.Emulator + Cardano.Node.Emulator.API + Cardano.Node.Emulator.Generators + Cardano.Node.Emulator.Internal.API + Cardano.Node.Emulator.Internal.Node + Cardano.Node.Emulator.Internal.Node.Chain + Cardano.Node.Emulator.Internal.Node.Params + Cardano.Node.Emulator.Internal.Node.TimeSlot + Cardano.Node.Emulator.Internal.Node.Validation + Cardano.Node.Emulator.LogMessages + hs-source-dirs: + src + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wunused-packages -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints -Wmissing-import-lists -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: + aeson >=2 + , base >=4.9 && <5 + , bytestring , cardano-api , cardano-api:gen , cardano-crypto @@ -69,26 +51,22 @@ library , cardano-ledger-core , cardano-ledger-shelley , cardano-slotting - , ouroboros-consensus - , plutus-ledger-api - , plutus-tx - , sop-extras - , strict-sop-core - - ------------------------ - -- Non-IOG dependencies - ------------------------ - build-depends: - , aeson >=2 - , base >=4.9 && <5 - , bytestring , containers , data-default - , freer-simple + , freer-extras , hedgehog , lens , mtl - , prettyprinter >=1.1.0.1 + , ouroboros-consensus + , plutus-ledger + , plutus-ledger-api + , plutus-tx + , prettyprinter >=1.1.0.1 , sop-core + , sop-extras + , strict-sop-core , text , time + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False diff --git a/cardano-node-emulator/package.yaml b/cardano-node-emulator/package.yaml new file mode 100644 index 0000000..13614fc --- /dev/null +++ b/cardano-node-emulator/package.yaml @@ -0,0 +1,81 @@ +spec-version: 0.36.0 +name: cardano-node-emulator +version: 1.4.1.0 +language: Haskell2010 +default-extensions: + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - ExplicitForAll + - FlexibleContexts + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - NamedFieldPuns + - ScopedTypeVariables + - StandaloneDeriving +ghc-options: + - -Wall + - -Widentities + - -Wincomplete-record-updates + - -Wunused-packages + - -Wincomplete-uni-patterns + - -Wnoncanonical-monad-instances + - -Wredundant-constraints + - -Wmissing-import-lists + - -fobject-code + - -fno-ignore-interface-pragmas + - -fno-omit-interface-pragmas + - -fplugin-opt + - PlutusTx.Plugin:target-version=1.1.0 + - -fplugin-opt + - PlutusTx.Plugin:defer-errors + +library: + source-dirs: src + exposed-modules: + - Cardano.Node.Emulator + - Cardano.Node.Emulator.API + - Cardano.Node.Emulator.Generators + - Cardano.Node.Emulator.Internal.API + - Cardano.Node.Emulator.Internal.Node + - Cardano.Node.Emulator.Internal.Node.Chain + - Cardano.Node.Emulator.Internal.Node.Params + - Cardano.Node.Emulator.Internal.Node.TimeSlot + - Cardano.Node.Emulator.Internal.Node.Validation + - Cardano.Node.Emulator.LogMessages + dependencies: + - aeson >=2 + - base >=4.9 && <5 + - bytestring + - cardano-api + - cardano-api:gen + - cardano-crypto + - cardano-ledger-alonzo + - cardano-ledger-api + - cardano-ledger-binary + - cardano-ledger-conway + - cardano-ledger-core + - cardano-ledger-shelley + - cardano-slotting + - containers + - data-default + - freer-extras + - hedgehog + - lens + - mtl + - ouroboros-consensus + - plutus-ledger + - plutus-ledger-api + - plutus-tx + - prettyprinter >=1.1.0.1 + - sop-core + - sop-extras + - strict-sop-core + - text + - time + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs index aee5eff..b94a091 100644 --- a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs @@ -137,8 +137,7 @@ posixTimeRangeToContainedSlotRange :: SlotConfig -> POSIXTimeRange -> SlotRange posixTimeRangeToContainedSlotRange sc ptr = case fmap (posixTimeToEnclosingSlot sc) ptr of Interval (LowerBound start startIncl) (UpperBound end endIncl) -> Interval - ( LowerBound start (case start of Finite s -> slotToBeginPOSIXTime sc s `member` ptr; _ -> startIncl) - ) + (LowerBound start (case start of Finite s -> slotToBeginPOSIXTime sc s `member` ptr; _ -> startIncl)) (UpperBound end (case end of Finite e -> slotToEndPOSIXTime sc e `member` ptr; _ -> endIncl)) {-# INLINEABLE posixTimeToEnclosingSlot #-} diff --git a/cardano-node-socket-emulator/cardano-node-socket-emulator.cabal b/cardano-node-socket-emulator/cardano-node-socket-emulator.cabal index d8948da..78f480d 100644 --- a/cardano-node-socket-emulator/cardano-node-socket-emulator.cabal +++ b/cardano-node-socket-emulator/cardano-node-socket-emulator.cabal @@ -1,64 +1,44 @@ -cabal-version: 3.8 -name: cardano-node-socket-emulator -version: 1.4.1.0 - -common lang - default-language: Haskell2010 - default-extensions: - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - ExplicitForAll - FlexibleContexts - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - NamedFieldPuns - ScopedTypeVariables - StandaloneDeriving +cabal-version: 3.0 - ghc-options: - -Wall -Widentities -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wredundant-constraints -fplugin-opt - PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt - PlutusTx.Plugin:defer-errors +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False +name: cardano-node-socket-emulator +version: 1.4.1.0 +build-type: Simple library - import: lang - hs-source-dirs: src exposed-modules: - Cardano.Node.Socket.Emulator - Cardano.Node.Socket.Emulator.Mock - Cardano.Node.Socket.Emulator.Params - Cardano.Node.Socket.Emulator.Query - Cardano.Node.Socket.Emulator.Server - Cardano.Node.Socket.Emulator.Types - Plutus.Monitoring.Util - - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False - - -------------------- - -- Local components - -------------------- - build-depends: - , cardano-node-emulator - , freer-extras - , plutus-ledger - , plutus-script-utils - - -------------------------- - -- Other IOG dependencies - -------------------------- + Cardano.Node.Socket.Emulator + Cardano.Node.Socket.Emulator.Mock + Cardano.Node.Socket.Emulator.Params + Cardano.Node.Socket.Emulator.Query + Cardano.Node.Socket.Emulator.Server + Cardano.Node.Socket.Emulator.Types + Plutus.Monitoring.Util + hs-source-dirs: + src + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: + aeson >=2 + , async + , base >=4.9 && <5 + , bytestring , cardano-api , cardano-ledger-api , cardano-ledger-byron @@ -67,58 +47,64 @@ library , cardano-ledger-shelley , cardano-ledger-shelley-test , cardano-ledger-shelley:testlib + , cardano-node-emulator , cardano-protocol-tpraos , cardano-protocol-tpraos:testlib , cardano-slotting + , containers + , contra-tracer , cryptonite + , data-default , exceptions + , freer-extras , io-classes - , iohk-monitoring + , lens , memory , network-mux - , ouroboros-consensus - , ouroboros-consensus-cardano - , ouroboros-consensus-diffusion - , ouroboros-consensus-protocol - , ouroboros-network - , ouroboros-network-api - , ouroboros-network-framework - , ouroboros-network-protocols - , serialise - , strict-sop-core - , typed-protocols - , typed-protocols-cborg - , typed-protocols-stateful - - ------------------------ - -- Non-IOG dependencies - ------------------------ - build-depends: - , aeson >=2 - , async - , base >=4.9 && <5 - , bytestring - , containers - , contra-tracer - , data-default - , freer-simple - , lens - , mtl + , ouroboros-consensus:{cardano,diffusion,protocol} + , ouroboros-network:{api,framework,protocols} + , plutus-ledger + , plutus-script-utils , prettyprinter + , serialise , sop-core , stm + , strict-sop-core , text , time , time-units + , trace-dispatcher + , typed-protocols + , typed-protocols-stateful + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False executable cardano-node-socket-emulator - import: lang - main-is: Main.hs - hs-source-dirs: app - default-language: Haskell2010 - build-depends: cardano-node-socket-emulator - build-depends: iohk-monitoring + main-is: Main.hs + hs-source-dirs: + app + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + NamedFieldPuns + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: - , base >=4.9 && <5 + base >=4.9 && <5 + , cardano-node-socket-emulator , data-default , prettyprinter + , trace-dispatcher + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False diff --git a/cardano-node-socket-emulator/package.yaml b/cardano-node-socket-emulator/package.yaml new file mode 100644 index 0000000..0594f3e --- /dev/null +++ b/cardano-node-socket-emulator/package.yaml @@ -0,0 +1,99 @@ +spec-version: 0.36.0 +name: cardano-node-socket-emulator +version: 1.4.1.0 +language: Haskell2010 +default-extensions: + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - ExplicitForAll + - FlexibleContexts + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - NamedFieldPuns + - ScopedTypeVariables + - StandaloneDeriving +ghc-options: + - -Wall + - -Widentities + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wnoncanonical-monad-instances + - -Wredundant-constraints + - -fplugin-opt + - PlutusTx.Plugin:target-version=1.1.0 + - -fplugin-opt + - PlutusTx.Plugin:defer-errors + +library: + source-dirs: src + exposed-modules: + - Cardano.Node.Socket.Emulator + - Cardano.Node.Socket.Emulator.Mock + - Cardano.Node.Socket.Emulator.Params + - Cardano.Node.Socket.Emulator.Query + - Cardano.Node.Socket.Emulator.Server + - Cardano.Node.Socket.Emulator.Types + - Plutus.Monitoring.Util + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false + dependencies: + - aeson >=2 + - async + - base >=4.9 && <5 + - bytestring + - cardano-api + - cardano-ledger-api + - cardano-ledger-byron + - cardano-ledger-core + - cardano-ledger-core:testlib + - cardano-ledger-shelley + - cardano-ledger-shelley-test + - cardano-ledger-shelley:testlib + - cardano-node-emulator + - cardano-protocol-tpraos + - cardano-protocol-tpraos:testlib + - cardano-slotting + - containers + - contra-tracer + - cryptonite + - data-default + - exceptions + - freer-extras + - io-classes + - lens + - memory + - network-mux + - ouroboros-consensus:{ouroboros-consensus, cardano, diffusion, protocol} + - ouroboros-network:{ouroboros-network, api, framework, protocols} + - plutus-ledger + - plutus-script-utils + - prettyprinter + - serialise + - sop-core + - stm + - strict-sop-core + - text + - time + - time-units + - trace-dispatcher + - typed-protocols + - typed-protocols-stateful + +executables: + cardano-node-socket-emulator: + main: Main.hs + source-dirs: app + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false + dependencies: + - base >=4.9 && <5 + - cardano-node-socket-emulator + - data-default + - prettyprinter + - trace-dispatcher diff --git a/dependency-summary-TO-BE-REMOVED.txt b/dependency-summary-TO-BE-REMOVED.txt new file mode 100644 index 0000000..19ebedd --- /dev/null +++ b/dependency-summary-TO-BE-REMOVED.txt @@ -0,0 +1,15 @@ +Dependency update summary + +What changed: +- Bumped the Hackage/Cardano index-state in cabal.project. +- Removed the stale tracer-transformers pin (0.1.0.4) that conflicted with newer contra-tracer. +- Replaced iohk-monitoring with trace-dispatcher in package dependencies. +- Removed typed-protocols-cborg and kept typed-protocols-stateful as the modern replacement. + +Why: +- tracer-transformers 0.1.0.4 only works with old contra-tracer bounds and blocks newer ouroboros-consensus/cardano-api resolution. +- iohk-monitoring pulls in contra-tracer constraints that conflict with the newer dependency set. +- typed-protocols-cborg no longer builds against typed-protocols 1.x; typed-protocols-stateful is the current codec path. + +Notes: +- The code still contains old iohk-monitoring / typed-protocols-cborg imports in a few places; this file only records the dependency-side cleanup. diff --git a/flake.lock b/flake.lock index 72298aa..b0f63e1 100644 --- a/flake.lock +++ b/flake.lock @@ -3,15 +3,15 @@ "flake-compat": { "flake": false, "locked": { - "lastModified": 1761588595, - "narHash": "sha256-XKUZz9zewJNUj46b4AJdiRZJAvSZ0Dqj2BNfXvFlJC4=", - "owner": "edolstra", + "lastModified": 1767039857, + "narHash": "sha256-vNpUSpF5Nuw8xvDLj2KCwwksIbjua2LZCqhV1LNRDns=", + "owner": "NixOS", "repo": "flake-compat", - "rev": "f387cd2afec9419c8ee37694406ca490c3f34ee5", + "rev": "5edf11c44bc78a0d334f6334cdaf7d60d732daab", "type": "github" }, "original": { - "owner": "edolstra", + "owner": "NixOS", "repo": "flake-compat", "type": "github" } @@ -34,34 +34,13 @@ "type": "github" } }, - "gitignore": { - "inputs": { - "nixpkgs": [ - "pre-commit-hooks", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1709087332, - "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", - "owner": "hercules-ci", - "repo": "gitignore.nix", - "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", - "type": "github" - }, - "original": { - "owner": "hercules-ci", - "repo": "gitignore.nix", - "type": "github" - } - }, "nixpkgs": { "locked": { - "lastModified": 1764547213, - "narHash": "sha256-pGXM6frMKLRJmeMcQ228O1QQBuNEUjzmWx9uBd+CbXM=", + "lastModified": 1788902827, + "narHash": "sha256-2jlezdUpU3YMrz3sAkdYCyA8poHanN8zchVXnVssLQo=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "64de27c1c985895c1a9f92aaeaab4e6a4c0960f5", + "rev": "5362b74747c99552d1e8be5f834a32cb817296e6", "type": "github" }, "original": { @@ -73,17 +52,16 @@ "pre-commit-hooks": { "inputs": { "flake-compat": "flake-compat", - "gitignore": "gitignore", "nixpkgs": [ "nixpkgs" ] }, "locked": { - "lastModified": 1763988335, - "narHash": "sha256-QlcnByMc8KBjpU37rbq5iP7Cp97HvjRP0ucfdh+M4Qc=", + "lastModified": 1788267358, + "narHash": "sha256-nt+lUqYVpc9Y6JeMd2WmXzCDojasdadKo0mWcluvY2Y=", "owner": "cachix", "repo": "pre-commit-hooks.nix", - "rev": "50b9238891e388c9fdc6a5c49e49c42533a1b5ce", + "rev": "27555e2624241fb116b49095df4caaee85a25691", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 743317a..ae7db6e 100644 --- a/flake.nix +++ b/flake.nix @@ -4,34 +4,40 @@ inputs.pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; inputs.pre-commit-hooks.inputs.nixpkgs.follows = "nixpkgs"; - outputs = { self, nixpkgs, flake-utils, pre-commit-hooks }: - flake-utils.lib.eachDefaultSystem (system: + outputs = + { + self, + nixpkgs, + flake-utils, + pre-commit-hooks, + }: + flake-utils.lib.eachDefaultSystem ( + system: let pkgs = nixpkgs.legacyPackages.${system}; - hpkgs = pkgs.haskell.packages.ghc96; + hpkgs = pkgs.haskell.packages.ghc912; ## We change the way 'blst' is built so that it takes into ## account the current architecture of the processor. This ## is due to a bug where older processors (>= 10 years) ## would not be supported. This should not change anything ## on newer machines. This could be revised in the future. - blst-portable = pkgs.blst.overrideAttrs (_: _: { - buildPhase = '' - runHook preBuild - ./build.sh -shared -D__BLST_PORTABLE__ ${ - pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isWindows - "flavour=mingw64" - } - runHook postBuild - ''; - }); + blst-portable = pkgs.blst.overrideAttrs ( + _: _: { + buildPhase = '' + runHook preBuild + ./build.sh -shared -D__BLST_PORTABLE__ ${pkgs.lib.optionalString pkgs.stdenv.hostPlatform.isWindows "flavour=mingw64"} + runHook postBuild + ''; + } + ); pre-commit = pre-commit-hooks.lib.${system}.run { src = ./.; hooks = { - nixfmt-classic.enable = true; + nixfmt.enable = true; ormolu.enable = true; - cabal-fmt.enable = true; + hpack.enable = true; }; tools = { ## This setting specifies which tools to use in the `pre-commit` @@ -45,75 +51,84 @@ ## for more information. }; }; - in rec { - formatter = pkgs.nixfmt-classic; + in + rec { + formatter = pkgs.nixfmt; - devShells = let - ## The minimal dependency set to build the project with `cabal`. - buildInputs = [ - blst-portable - pkgs.pkg-config - pkgs.glibcLocales - pkgs.zlib - pkgs.libsodium - pkgs.secp256k1 - pkgs.lmdb - hpkgs.ghc - hpkgs.cabal-install - ]; + devShells = + let + ## The minimal dependency set to build the project with `cabal`. + buildInputs = [ + blst-portable + pkgs.pkg-config + pkgs.glibcLocales + pkgs.zlib + pkgs.libsodium + pkgs.secp256k1 + pkgs.lmdb + hpkgs.ghc + hpkgs.cabal-install + ] + ## liburing (Linux io_uring) is required to build `blockio` with + ## its native (non-serial) backend, which `ouroboros-consensus` + ## depends on transitively. It's Linux-only, hence the guard. + ++ pkgs.lib.optional pkgs.stdenv.hostPlatform.isLinux pkgs.liburing; - ## Folders in which to find ".so" files - LD_LIBRARY_PATH = pkgs.lib.strings.makeLibraryPath [ - pkgs.xz - pkgs.zlib - pkgs.lmdb - pkgs.openssl_3_6 - pkgs.postgresql # For cardano-node-emulator - pkgs.openldap # For freer-extras‽ - ]; + ## Folders in which to find ".so" files + LD_LIBRARY_PATH = pkgs.lib.strings.makeLibraryPath [ + pkgs.xz + pkgs.zlib + pkgs.lmdb + pkgs.openssl_3_6 + pkgs.postgresql # For cardano-node-emulator + pkgs.openldap # For freer-extras‽ + ]; - LANG = "C.UTF-8"; + LANG = "C.UTF-8"; - in { - ci = pkgs.mkShell { - inherit buildInputs; - inherit LD_LIBRARY_PATH; - inherit LANG; - }; + in + { + ci = pkgs.mkShell { + inherit buildInputs; + inherit LD_LIBRARY_PATH; + inherit LANG; + }; - default = pkgs.mkShell { - buildInputs = buildInputs ++ [ - pkgs.hpack - pkgs.hlint - hpkgs.ormolu - hpkgs.haskell-language-server - ]; + default = pkgs.mkShell { + buildInputs = buildInputs ++ [ + pkgs.hpack + pkgs.hlint + hpkgs.ormolu + hpkgs.haskell-language-server + hpkgs.cabal-plan + ]; - inherit LD_LIBRARY_PATH; - inherit LANG; + inherit LD_LIBRARY_PATH; + inherit LANG; - # In addition to the pre-commit hooks, this redefines a cabal - # command that gets rid of annoying "Writing: .....*.html" output - # when running cabal test. - shellHook = pre-commit.shellHook + '' - function cabal() { - if [ "$1" != "test" ]; then - command cabal "$@" - else - command cabal --test-option=--color=always "$@" | grep -vE --color=never "^Writing:.*html$" - fi - } - export -f cabal - ''; + # In addition to the pre-commit hooks, this redefines a cabal + # command that gets rid of annoying "Writing: .....*.html" output + # when running cabal test. + shellHook = pre-commit.shellHook + '' + function cabal() { + if [ "$1" != "test" ]; then + command cabal "$@" + else + command cabal --test-option=--color=always "$@" | grep -vE --color=never "^Writing:.*html$" + fi + } + export -f cabal + ''; + }; }; - }; checks = { inherit pre-commit; }; # since this flake is not building the project actually, but just providing a dev shell, # Hydra will just test if the devShell is actually buildable hydraJobs.required = devShells.default; - }); + } + ); nixConfig = { extra-trusted-substituters = [ diff --git a/freer-extras/freer-extras.cabal b/freer-extras/freer-extras.cabal index 3719fe4..4e14cf1 100644 --- a/freer-extras/freer-extras.cabal +++ b/freer-extras/freer-extras.cabal @@ -1,82 +1,82 @@ -cabal-version: 3.8 +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + name: freer-extras version: 1.4.0.0 synopsis: Useful extensions to simple-freer -description: - freer-extras provides logging and monitoring functions extending simple-freer - +description: freer-extras provides logging and monitoring functions extending simple-freer bug-reports: https://github.com/input-output-hk/plutus-apps/issues -license: Apache-2.0 -license-file: LICENSE author: Tobias Pflug maintainer: tobias.pflug@iohk.io +license: Apache-2.0 +license-file: LICENSE build-type: Simple -common lang - default-language: Haskell2010 - default-extensions: - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - ExplicitForAll - GeneralizedNewtypeDeriving - ImportQualifiedPost - ScopedTypeVariables - StandaloneDeriving - - ghc-options: - -Wall -Wnoncanonical-monad-instances -Wunused-packages - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities - library - import: lang - hs-source-dirs: src exposed-modules: - Control.Monad.Freer.Extras - Control.Monad.Freer.Extras.Delay - Control.Monad.Freer.Extras.Log - Control.Monad.Freer.Extras.Modify - Control.Monad.Freer.Extras.Pagination - Control.Monad.Freer.Extras.State - Control.Monad.Freer.Extras.Stream - - ------------------------ - -- Non-IOG dependencies - ------------------------ + Control.Monad.Freer.Extras + Control.Monad.Freer.Extras.Delay + Control.Monad.Freer.Extras.Log + Control.Monad.Freer.Extras.Modify + Control.Monad.Freer.Extras.Pagination + Control.Monad.Freer.Extras.State + Control.Monad.Freer.Extras.Stream + hs-source-dirs: + src + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + GeneralizedNewtypeDeriving + ImportQualifiedPost + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Wnoncanonical-monad-instances -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fplugin=Polysemy.Plugin build-depends: - , aeson - , base >=4.7 && <5 + aeson + , base >=4.7 && <5 , containers , data-default - , freer-simple , lens , mtl + , polysemy + , polysemy-plugin , prettyprinter , streaming , text , time-units + default-language: Haskell2010 test-suite freer-extras-test - import: lang - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test - other-modules: Control.Monad.Freer.Extras.PaginationSpec - - ---------------------------- - -- Local components - ---------------------------- - build-depends: freer-extras ^>=1.4.0 - - ------------------------ - -- Non-IOG dependencies - ------------------------ + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Control.Monad.Freer.Extras.PaginationSpec + hs-source-dirs: + test + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + GeneralizedNewtypeDeriving + ImportQualifiedPost + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Wnoncanonical-monad-instances -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fplugin=Polysemy.Plugin build-depends: - , base >=4.7 && <5 + base >=4.7 && <5 , containers + , freer-extras >=1.4.0 && <1.5 , hedgehog , tasty , tasty-hedgehog + default-language: Haskell2010 diff --git a/freer-extras/package.yaml b/freer-extras/package.yaml new file mode 100644 index 0000000..deb78b4 --- /dev/null +++ b/freer-extras/package.yaml @@ -0,0 +1,69 @@ +spec-version: 0.36.0 +name: freer-extras +version: 1.4.0.0 +synopsis: Useful extensions to simple-freer +description: freer-extras provides logging and monitoring functions extending simple-freer +bug-reports: https://github.com/input-output-hk/plutus-apps/issues +license: Apache-2.0 +license-file: LICENSE +author: Tobias Pflug +maintainer: tobias.pflug@iohk.io +build-type: Simple +language: Haskell2010 +default-extensions: + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - ExplicitForAll + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - ScopedTypeVariables + - StandaloneDeriving +ghc-options: + - -Wall + - -Wnoncanonical-monad-instances + - -Wunused-packages + - -Wincomplete-uni-patterns + - -Wincomplete-record-updates + - -Wredundant-constraints + - -Widentities + - -fplugin=Polysemy.Plugin + +library: + source-dirs: src + exposed-modules: + - Control.Monad.Freer.Extras + - Control.Monad.Freer.Extras.Delay + - Control.Monad.Freer.Extras.Log + - Control.Monad.Freer.Extras.Modify + - Control.Monad.Freer.Extras.Pagination + - Control.Monad.Freer.Extras.State + - Control.Monad.Freer.Extras.Stream + dependencies: + - aeson + - base >=4.7 && <5 + - containers + - data-default + - lens + - mtl + - polysemy + - polysemy-plugin + - prettyprinter + - streaming + - text + - time-units +tests: + freer-extras-test: + main: Spec.hs + source-dirs: test + other-modules: + - Control.Monad.Freer.Extras.PaginationSpec + dependencies: + - base >=4.7 && <5 + - containers + - freer-extras ^>=1.4.0 + - hedgehog + - tasty + - tasty-hedgehog diff --git a/freer-extras/src/Control/Monad/Freer/Extras/Log.hs b/freer-extras/src/Control/Monad/Freer/Extras/Log.hs index f091e25..0d0b5d1 100644 --- a/freer-extras/src/Control/Monad/Freer/Extras/Log.hs +++ b/freer-extras/src/Control/Monad/Freer/Extras/Log.hs @@ -228,8 +228,7 @@ handleWriterLog f = interpret $ \case -- | Re-interpret a 'Log' effect with a 'Writer' handleLogWriter :: forall a w effs. - ( Member (Writer w) effs - ) => + (Member (Writer w) effs) => AReview w (LogMessage a) -> LogMsg a ~> Eff effs diff --git a/plutus-ledger/package.yaml b/plutus-ledger/package.yaml new file mode 100644 index 0000000..c3ce1b0 --- /dev/null +++ b/plutus-ledger/package.yaml @@ -0,0 +1,133 @@ +spec-version: 0.36.0 +name: plutus-ledger +version: 1.4.1.0 +license: Apache-2.0 +license-file: + - LICENSE + - NOTICE +language: Haskell2010 +default-extensions: + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - ExplicitForAll + - FlexibleContexts + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - MultiParamTypeClasses + - ScopedTypeVariables + - StandaloneDeriving +ghc-options: + - -Wall + - -Wnoncanonical-monad-instances + - -Wno-unused-packages + - -Wincomplete-uni-patterns + - -Wincomplete-record-updates + - -Wredundant-constraints + - -Widentities + - -fobject-code + - -fno-ignore-interface-pragmas + - -fno-omit-interface-pragmas + - -fplugin-opt + - PlutusTx.Plugin:target-version=1.1.0 + - -fplugin-opt + - PlutusTx.Plugin:defer-errors + +library: + source-dirs: src + exposed-modules: + - Data.Aeson.Extras + - Data.Time.Units.Extra + - Ledger + - Ledger.Address + - Ledger.Address.Orphans + - Ledger.AddressMap + - Ledger.Blockchain + - Ledger.Builtins.Orphans + - Ledger.CardanoWallet + - Ledger.Credential.Orphans + - Ledger.Crypto + - Ledger.Crypto.Orphans + - Ledger.DCert.Orphans + - Ledger.Index + - Ledger.Index.Internal + - Ledger.Orphans + - Ledger.Scripts + - Ledger.Scripts.Orphans + - Ledger.Slot + - Ledger.Test + - Ledger.Tx + - Ledger.Tx.CardanoAPI + - Ledger.Tx.CardanoAPI.Internal + - Ledger.Tx.Internal + - Ledger.Tx.Orphans + - Ledger.Tx.Orphans.V1 + - Ledger.Tx.Orphans.V2 + - Ledger.Typed.Scripts.Orphans + - Ledger.Value.CardanoAPI + - Ledger.Value.Orphans + other-modules: + - Codec.CBOR.Extras + dependencies: + - aeson + - base >=4.9 && <5 + - base16-bytestring + - bytestring + - cborg + - cardano-api + - cardano-binary + - cardano-crypto + - cardano-ledger-alonzo + - cardano-ledger-byron + - cardano-ledger-conway + - cardano-ledger-core + - cardano-ledger-shelley + - containers + - cryptonite >=0.25 + - flat + - hashable + - http-api-data + - lens + - memory + - ordered-containers + - plutus-core + - plutus-ledger-api + - plutus-script-utils ^>=2.0.1 + - plutus-tx + - plutus-tx-plugin + - prettyprinter + - scientific + - serialise + - servant + - text + - time-units + - vector + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false + +tests: + plutus-ledger-test: + main: Spec.hs + source-dirs: test + other-modules: + - Ledger.Tx.CardanoAPISpec + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false + dependencies: + - aeson + - base >=4.9 && <5 + - bytestring + - cardano-api + - cardano-api:gen + - hedgehog + - plutus-ledger + - plutus-ledger-api + - plutus-script-utils + - plutus-tx + - tasty + - tasty-hedgehog + - tasty-hunit diff --git a/plutus-ledger/plutus-ledger.cabal b/plutus-ledger/plutus-ledger.cabal index def8fe7..a893e81 100644 --- a/plutus-ledger/plutus-ledger.cabal +++ b/plutus-ledger/plutus-ledger.cabal @@ -1,95 +1,71 @@ -cabal-version: 3.8 +cabal-version: 3.0 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + name: plutus-ledger version: 1.4.1.0 license: Apache-2.0 -license-files: - LICENSE - NOTICE - -common lang - default-language: Haskell2010 - default-extensions: - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - ExplicitForAll - FlexibleContexts - GeneralizedNewtypeDeriving - ImportQualifiedPost - MultiParamTypeClasses - ScopedTypeVariables - StandaloneDeriving - - -- See Plutus Tx readme for why we need the following flags: - -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas - ghc-options: - -Wall -Wnoncanonical-monad-instances -Wno-unused-packages - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities -fobject-code - -fno-ignore-interface-pragmas -fno-omit-interface-pragmas - -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt - PlutusTx.Plugin:defer-errors - - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False +license-files: LICENSE, + NOTICE +build-type: Simple library - import: lang - hs-source-dirs: src - default-language: Haskell2010 exposed-modules: - Data.Aeson.Extras - Data.Time.Units.Extra - Ledger - Ledger.Address - Ledger.Address.Orphans - Ledger.AddressMap - Ledger.Blockchain - Ledger.Builtins.Orphans - Ledger.CardanoWallet - Ledger.Credential.Orphans - Ledger.Crypto - Ledger.Crypto.Orphans - Ledger.DCert.Orphans - Ledger.Index - Ledger.Index.Internal - Ledger.Orphans - Ledger.Scripts - Ledger.Scripts.Orphans - Ledger.Slot - Ledger.Test - Ledger.Tx - Ledger.Tx.CardanoAPI - Ledger.Tx.CardanoAPI.Internal - Ledger.Tx.Internal - Ledger.Tx.Orphans - Ledger.Tx.Orphans.V1 - Ledger.Tx.Orphans.V2 - Ledger.Typed.Scripts.Orphans - Ledger.Value.CardanoAPI - Ledger.Value.Orphans - - -- The rest of the plutus-ledger-api modules are reexported from within - -- the Haskell modules and not in the current cabal file. - -- For example: PlutusLedgerApi.V1.Address is reexported by Ledger.Address - other-modules: Codec.CBOR.Extras - - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False - - -------------------- - -- Local components - -------------------- - build-depends: plutus-script-utils ^>=2.0.1 - - -------------------------- - -- Other IOG dependencies - -------------------------- + Data.Aeson.Extras + Data.Time.Units.Extra + Ledger + Ledger.Address + Ledger.Address.Orphans + Ledger.AddressMap + Ledger.Blockchain + Ledger.Builtins.Orphans + Ledger.CardanoWallet + Ledger.Credential.Orphans + Ledger.Crypto + Ledger.Crypto.Orphans + Ledger.DCert.Orphans + Ledger.Index + Ledger.Index.Internal + Ledger.Orphans + Ledger.Scripts + Ledger.Scripts.Orphans + Ledger.Slot + Ledger.Test + Ledger.Tx + Ledger.Tx.CardanoAPI + Ledger.Tx.CardanoAPI.Internal + Ledger.Tx.Internal + Ledger.Tx.Orphans + Ledger.Tx.Orphans.V1 + Ledger.Tx.Orphans.V2 + Ledger.Typed.Scripts.Orphans + Ledger.Value.CardanoAPI + Ledger.Value.Orphans + other-modules: + Codec.CBOR.Extras + hs-source-dirs: + src + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Wnoncanonical-monad-instances -Wno-unused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: + aeson + , base >=4.9 && <5 + , base16-bytestring + , bytestring , cardano-api , cardano-binary , cardano-crypto @@ -98,34 +74,20 @@ library , cardano-ledger-conway , cardano-ledger-core , cardano-ledger-shelley - , data-default - , iohk-monitoring - , plutus-core - , plutus-ledger-api - , plutus-tx - , plutus-tx-plugin - - ------------------------ - -- Non-IOG dependencies - ------------------------ - -- TODO: remove the contractmodel dependency once the dependency on cardano-node - -- has been bumped to include the instance of Ord for AddressInEra - -- defined there. - build-depends: - , aeson - , base >=4.9 && <5 - , base16-bytestring - , bytestring , cborg , containers - , cryptonite >=0.25 + , cryptonite >=0.25 , flat , hashable , http-api-data , lens , memory - , newtype-generics , ordered-containers + , plutus-core + , plutus-ledger-api + , plutus-script-utils >=2.0.1 && <2.1 + , plutus-tx + , plutus-tx-plugin , prettyprinter , scientific , serialise @@ -133,42 +95,45 @@ library , text , time-units , vector - - ghc-options: -fprint-potential-instances + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False test-suite plutus-ledger-test - import: lang - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - other-modules: Ledger.Tx.CardanoAPISpec - - -------------------- - -- Local components - -------------------- - build-depends: - , plutus-ledger - , plutus-script-utils - - -------------------------- - -- Other IOG dependencies - -------------------------- + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Ledger.Tx.CardanoAPISpec + hs-source-dirs: + test + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + ExplicitForAll + FlexibleContexts + GeneralizedNewtypeDeriving + ImportQualifiedPost + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + ghc-options: -Wall -Wnoncanonical-monad-instances -Wno-unused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: + aeson + , base >=4.9 && <5 + , bytestring , cardano-api , cardano-api:gen + , hedgehog + , plutus-ledger , plutus-ledger-api + , plutus-script-utils , plutus-tx - - ------------------------ - -- Non-IOG dependencies - ------------------------ - build-depends: - , aeson - , base >=4.9 && <5 - , bytestring - , hedgehog , tasty , tasty-hedgehog , tasty-hunit + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False diff --git a/plutus-ledger/src/Ledger/Tx.hs b/plutus-ledger/src/Ledger/Tx.hs index 209464c..70501e3 100644 --- a/plutus-ledger/src/Ledger/Tx.hs +++ b/plutus-ledger/src/Ledger/Tx.hs @@ -353,8 +353,8 @@ instance Pretty CardanoTx where ) ] ++ [ hang 2 (vsep ("required signatures:" : (viaShow <$> wits))) - | let wits = getCardanoTxExtraKeyWitnesses tx, - not (null wits) + | let wits = getCardanoTxExtraKeyWitnesses tx, + not (null wits) ] ++ renderScriptWitnesses tx in nest 2 $ vsep ["Tx" <+> pretty (getCardanoTxId tx) <> colon, vsep lines'] diff --git a/plutus-script-utils/package.yaml b/plutus-script-utils/package.yaml new file mode 100644 index 0000000..a05433d --- /dev/null +++ b/plutus-script-utils/package.yaml @@ -0,0 +1,104 @@ +spec-version: 0.36.0 +name: plutus-script-utils +version: 2.0.1.0 +license: Apache-2.0 +license-file: + - LICENSE + - NOTICE +language: Haskell2010 +default-extensions: + - ConstraintKinds + - DataKinds + - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - EmptyDataDeriving + - FlexibleContexts + - FlexibleInstances + - GADTs + - GeneralizedNewtypeDeriving + - ImportQualifiedPost + - LambdaCase + - MultiParamTypeClasses + - MultiWayIf + - NamedFieldPuns + - NumericUnderscores + - OverloadedStrings + - PolyKinds + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - ViewPatterns +ghc-options: + - -Wall + - -Wcompat + - -Wincomplete-record-updates + - -Wincomplete-uni-patterns + - -Wnoncanonical-monad-instances + - -Wno-unused-packages + - -Wredundant-constraints + - -Widentities + - -Wmissing-import-lists + - -Wno-missed-extra-shared-lib + - -fobject-code + - -fno-ignore-interface-pragmas + - -fignore-hpc-changes + - -fno-omit-interface-pragmas + - -fplugin-opt + - PlutusTx.Plugin:target-version=1.1.0 + - -fplugin-opt + - PlutusTx.Plugin:defer-errors + - -fplugin-opt + - PlutusTx.Plugin:conservative-optimisation + +library: + source-dirs: src + exposed-modules: + - Plutus.Script.Utils.Address + - Plutus.Script.Utils.Data + - Plutus.Script.Utils.Scripts + - Plutus.Script.Utils.V1 + - Plutus.Script.Utils.V1.Contexts + - Plutus.Script.Utils.V1.Generators + - Plutus.Script.Utils.V1.Scripts + - Plutus.Script.Utils.V1.Typed + - Plutus.Script.Utils.V2 + - Plutus.Script.Utils.V2.Contexts + - Plutus.Script.Utils.V2.Generators + - Plutus.Script.Utils.V2.Scripts + - Plutus.Script.Utils.V2.Typed + - Plutus.Script.Utils.V3 + - Plutus.Script.Utils.V3.Contexts + - Plutus.Script.Utils.V3.Generators + - Plutus.Script.Utils.V3.Typed + - Plutus.Script.Utils.Value + - Prettyprinter.Extras + dependencies: + - aeson + - base >=4.9 && <5 + - bytestring + - cardano-api + - cardano-ledger-core + - data-default + - mtl + - plutus-core + - plutus-ledger-api + - plutus-tx + - plutus-tx-plugin + - prettyprinter + - serialise + - tagged + when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false diff --git a/plutus-script-utils/plutus-script-utils.cabal b/plutus-script-utils/plutus-script-utils.cabal index ec6829a..1135c0e 100644 --- a/plutus-script-utils/plutus-script-utils.cabal +++ b/plutus-script-utils/plutus-script-utils.cabal @@ -1,117 +1,89 @@ -cabal-version: 3.8 +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + name: plutus-script-utils version: 2.0.1.0 license: Apache-2.0 -license-files: - LICENSE - NOTICE - -common lang - default-language: Haskell2010 - default-extensions: - ConstraintKinds - DataKinds - DeriveAnyClass - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - DerivingStrategies - DerivingVia - EmptyDataDeriving - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - OverloadedStrings - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TupleSections - TypeApplications - TypeFamilies - TypeOperators - ViewPatterns - - -- See Plutus Tx readme for why we need the following flags: - -- -fobject-code -fno-ignore-interface-pragmas and -fno-omit-interface-pragmas - ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wno-unused-packages -Wincomplete-uni-patterns - -Wincomplete-record-updates -Wredundant-constraints -Widentities - -Wmissing-import-lists -Wno-missed-extra-shared-lib -fobject-code - -fno-ignore-interface-pragmas -fignore-hpc-changes - -fno-omit-interface-pragmas -fplugin-opt - PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt - PlutusTx.Plugin:defer-errors -fplugin-opt - PlutusTx.Plugin:conservative-optimisation - - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False +license-files: LICENSE, + NOTICE +build-type: Simple library - import: lang - hs-source-dirs: src - default-language: Haskell2010 exposed-modules: - Plutus.Script.Utils.Address - Plutus.Script.Utils.Data - Plutus.Script.Utils.Scripts - Plutus.Script.Utils.V1 - Plutus.Script.Utils.V1.Contexts - Plutus.Script.Utils.V1.Generators - Plutus.Script.Utils.V1.Scripts - Plutus.Script.Utils.V1.Typed - Plutus.Script.Utils.V2 - Plutus.Script.Utils.V2.Contexts - Plutus.Script.Utils.V2.Generators - Plutus.Script.Utils.V2.Scripts - Plutus.Script.Utils.V2.Typed - Plutus.Script.Utils.V3 - Plutus.Script.Utils.V3.Contexts - Plutus.Script.Utils.V3.Generators - Plutus.Script.Utils.V3.Typed - Plutus.Script.Utils.Value - Prettyprinter.Extras - - -- The limitation of plutus-tx-plugin - if (impl(ghc <9.6) || impl(ghc >=9.7)) - buildable: False - - -------------------------- - -- Other IOG dependencies - -------------------------- + Plutus.Script.Utils.Address + Plutus.Script.Utils.Data + Plutus.Script.Utils.Scripts + Plutus.Script.Utils.V1 + Plutus.Script.Utils.V1.Contexts + Plutus.Script.Utils.V1.Generators + Plutus.Script.Utils.V1.Scripts + Plutus.Script.Utils.V1.Typed + Plutus.Script.Utils.V2 + Plutus.Script.Utils.V2.Contexts + Plutus.Script.Utils.V2.Generators + Plutus.Script.Utils.V2.Scripts + Plutus.Script.Utils.V2.Typed + Plutus.Script.Utils.V3 + Plutus.Script.Utils.V3.Contexts + Plutus.Script.Utils.V3.Generators + Plutus.Script.Utils.V3.Typed + Plutus.Script.Utils.Value + Prettyprinter.Extras + hs-source-dirs: + src + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyDataDeriving + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wno-unused-packages -Wredundant-constraints -Widentities -Wmissing-import-lists -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation build-depends: + aeson + , base >=4.9 && <5 + , bytestring , cardano-api , cardano-ledger-core + , data-default + , mtl , plutus-core , plutus-ledger-api , plutus-tx , plutus-tx-plugin - - ------------------------ - -- Non-IOG dependencies - ------------------------ - build-depends: - , aeson - , base >=4.9 && <5 - , bytestring - , data-default - , mtl , prettyprinter , serialise , tagged - - ghc-options: -fprint-potential-instances + default-language: Haskell2010 + if !((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13))) + buildable: False diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed.hs b/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed.hs index 076ae79..2a87bd1 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/V2/Typed.hs @@ -154,7 +154,8 @@ checkDatum _ (Datum d) = Nothing -> throwError $ WrongDatumType d -- | A 'TxOut' tagged by a phantom type: and the connection type of the output. -data TypedScriptTxOut a = (IsDataDatum a) => +data TypedScriptTxOut a + = (IsDataDatum a) => TypedScriptTxOut { tyTxOutTxOut :: TxOut, tyTxOutData :: DatumType a From 9b271668354105c9731ec2dd1ba122ae793d237c Mon Sep 17 00:00:00 2001 From: mmontin Date: Wed, 9 Sep 2026 13:55:48 +0200 Subject: [PATCH 2/8] remove fourmolu --- .github/copilot-instructions.md | 219 ++++++++++++++++++++++++++++++++ CONTRIBUTING.md | 2 +- fourmolu.yaml | 48 ------- 3 files changed, 220 insertions(+), 49 deletions(-) create mode 100644 .github/copilot-instructions.md delete mode 100644 fourmolu.yaml diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md new file mode 100644 index 0000000..46955f1 --- /dev/null +++ b/.github/copilot-instructions.md @@ -0,0 +1,219 @@ +# Copilot Instructions for cardano-node-emulator + +## Repository Overview + +This is a Haskell project that provides an in-memory blockchain emulator for testing Cardano smart contracts and transactions. The repository is organized as a multi-package Cabal project with five main packages: + +- **cardano-node-emulator**: Core emulator providing an in-memory blockchain +- **cardano-node-socket-emulator**: Socket-based wrapper exposing node-to-client protocol over Unix sockets +- **plutus-ledger**: Ledger types and functionality for Plutus scripts and transactions +- **plutus-script-utils**: Utilities for writing and working with Plutus scripts +- **freer-extras**: Extensions to the `simple-freer` effect system + +## Development Environment + +**Required setup**: Use Nix exclusively to ensure consistent tool versions across all developers. + +```bash +# Enter development shell with all dependencies and tools pre-configured +nix develop + +# Inside nix develop, you'll see a menu of available commands +``` + +The development shell provides: +- GHC 9.6.6 (Haskell compiler) +- Cabal 3.14.1.0 (build tool) +- HLint (linter) +- Ormolu (code formatter) +- Hpack (package definition formatter) +- Pre-commit hooks (automatically run on git commit) + +**Without Nix** (not recommended): Refer to CONTRIBUTING.md for workarounds, but be aware you may encounter version mismatches. + +## Build, Test & Lint Commands + +### Building + +```bash +# Build entire workspace +cabal build all + +# Build a specific package (e.g., cardano-node-emulator) +cabal build cardano-node-emulator + +# Build with tests enabled +cabal build all --enable-tests +``` + +### Testing + +```bash +# Run all tests in the workspace +cabal test all --test-show-details=direct + +# Run tests for a specific package +cabal test cardano-node-emulator --test-show-details=direct + +# Run a single test module +cabal test cardano-node-emulator --test-show-details=direct -- +RTS -N1 -RTS + +# Parallel test execution is not supported; tests run sequentially (-j1) +``` + +### Code Quality + +```bash +# Lint code with HLint +hlint . + +# Format Haskell code with Ormolu +# This runs automatically via pre-commit hooks on `git commit` +``` + +### Documentation + +```bash +# Generate Haddock documentation for a package +cabal haddock cardano-node-emulator +``` + +## Key Architecture & Design Patterns + +### Multi-Package Structure + +Each package is self-contained with its own `package.yaml` (processed by hpack into `.cabal`), dependencies, and tests. Packages can depend on one another but should maintain clear boundaries. + +### Dependency Management + +Dependencies are pinned to specific versions using `cabal.project`: +- **Hackage index state**: Pinned to a specific timestamp for reproducibility +- **CHaP (Cardano Haskell Packages)**: Additional repository for Cardano-specific packages +- **Source repository packages**: Rarely used; avoid unless necessary (prefer releasing to CHaP) + +To update dependencies: Edit the `index-state` in `cabal.project` and run `cabal update`. + +### Effect System + +The codebase uses `simple-freer` (Freer monad) for effect composition. The `freer-extras` package provides common extensions and utilities for this. + +### Testing with Generators + +The emulator includes test data generators in `Cardano.Node.Emulator.Generators` for creating realistic test scenarios. + +## Code Conventions + +### Haskell Style + +- **Column limit**: 100 characters +- **Indentation**: 2 spaces +- **Import style**: `ImportQualifiedPost` enabled (imports appear after the module name) +- **Module organization**: Explicit module exports required (`-Wmissing-import-lists`) +- **Type safety**: Enabled `ScopedTypeVariables`, `StandaloneDeriving`, and strict pattern matching checks + +### Common Extensions in Use + +Packages enable these by default (check individual `.cabal` files): +- `DeriveFoldable`, `DeriveFunctor`, `DeriveGeneric`: Automatic deriving +- `ExplicitForAll`: Explicit type parameters +- `FlexibleContexts`, `GeneralizedNewtypeDeriving`: More expressive type constraints +- `LambdaCase`: Pattern matching in lambda expressions +- `NamedFieldPuns`: Record field punning +- `ImportQualifiedPost`: Qualified imports after module name + +### GHC Compiler Flags + +All packages compile with: +``` +-Wall -Widentities -Wincomplete-record-updates -Wunused-packages +-Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints +-Wmissing-import-lists +``` + +Plugin flags for PlutusTx scripts: +``` +-fplugin-opt PlutusTx.Plugin:target-version=1.1.0 +-fplugin-opt PlutusTx.Plugin:defer-errors +``` + +### HLint Rules + +See `.hlint.yaml` for exceptions. Notable patterns: +- `Move brackets to avoid $` is ignored (rarely an improvement) +- `Use <$>` is ignored (clarity is preferred) +- `Avoid lambda` is ignored (named parameters aid clarity) + +### Code Structure + +- **API boundaries**: Core functionality is in `Cardano.Node.Emulator.API` (public interface) +- **Internal modules**: Implementation details use `Internal.` prefix and are not part of the public API +- **Module hierarchy**: Follows the package structure; internal modules are namespaced separately + +## Testing Practices + +- Tests are located in a `test/` directory within each package +- Use Tasty for test framework (the standard in this codebase) +- Tests require `TMPDIR`/`TMP` environment variables to be set (GitHub Actions uses `runner.temp`) +- Some tests are stateful and sensitive to parallelism; run with `-j1` +- Test output is colored and displayed directly (see `test-show-details: direct` in `cabal.project`) + +## Pre-commit Hooks + +Configured in `flake.nix`: +- **Ormolu**: Formats Haskell files +- **Nixfmt**: Formats Nix files +- **Hpack**: Validates and can regenerate `.cabal` files from `package.yaml` + +These run automatically on commit when inside `nix develop`. To bypass (not recommended): `git commit --no-verify`. + +## CI/CD Pipeline + +GitHub Actions runs: +1. Dependency resolution with dry-run build plan +2. Cached dependency build +3. Full build of all packages with tests enabled +4. Test execution with direct output +5. Artifact collection and upload + +Cache is invalidated via `CABAL_CACHE_VERSION` in `.github/workflows/haskell.yml`. + +## File Locations Reference + +- **Main source**: `/src/` (Haskell source files) +- **Package definitions**: `/package.yaml` (processed to `.cabal`) +- **Tests**: `/test/` +- **Cabal configuration**: `cabal.project` (workspace), `/.cabal` (per-package) +- **Nix configuration**: `flake.nix`, `nix/` directory +- **Linting**: `.hlint.yaml` +- **CI/CD**: `.github/workflows/` + +## Common Tasks + +### Adding a new Haskell package + +1. Create the package directory: `mkdir my-package` +2. Add `package.yaml` and `src/` structure +3. Add the package to `cabal.project` under `packages:` +4. Run `cabal build my-package --enable-tests` to verify +5. CI will validate the Nix build + +### Updating GHC version + +1. Edit the GHC version in `nix/project.nix` (IOGX config) +2. Restart `nix develop` shell +3. Compile packages and fix any compilation errors +4. Update CI workflow if needed (currently 9.6.6) + +### Managing dependencies + +1. Edit the `package.yaml` for your package +2. If you need a newer version available only after the current `index-state`, bump the timestamp in `cabal.project` +3. Run `cabal update` and `cabal build` to verify the plan works +4. If breakage occurs, add upper/lower bounds to fix it + +## Useful Resources + +- **Cardano Engineering Handbook**: https://input-output-hk.github.io/cardano-engineering-handbook +- **Contributing Guide**: See CONTRIBUTING.md for detailed development instructions +- **Nix Setup**: Refer to https://github.com/input-output-hk/iogx/blob/main/doc/nix-setup-guide.md +- **Cardano Haskell Packages**: https://github.com/input-output-hk/cardano-haskell-packages diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a5dbad7..82cf369 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -302,7 +302,7 @@ See [the readthedocs page](https://plutus-apps.readthedocs.io/en/latest/adr/inde We use `ormolu` for Haskell code formatting, `nixfmt-classic` for nix files and `cabal-fmt` for cabal files. They are run automatically as pre-commit hooks, but CI will run them again and expect that to be a no-op, so if you somehow don't apply them your PR will not go green. -To run `fourmolu` or `cabal-fmt` manually over your tree, type `pre-commit run fourmolu` or `pre-commit run cabal-fmt` respectively. +To run `ormolu` or `hpack` manually over your tree, type `pre-commit run ormolu` or `pre-commit run hpack` respectively. They are provided by the `nix develop` environment. ### Compiler warnings diff --git a/fourmolu.yaml b/fourmolu.yaml deleted file mode 100644 index 8f9172a..0000000 --- a/fourmolu.yaml +++ /dev/null @@ -1,48 +0,0 @@ -# Number of spaces per indentation step -indentation: 2 - -# Max line length for automatic line breaking -column-limit: 100 - -# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) -function-arrows: leading - -# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) -comma-style: leading - -# Styling of import/export lists (choices: leading, trailing, or diff-friendly) -import-export-style: diff-friendly - -# Whether to full-indent or half-indent 'where' bindings past the preceding body -indent-wheres: true - -# Whether to leave a space before an opening record brace -record-brace-space: false - -# Number of spaces between top-level declarations -newlines-between-decls: 1 - -# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) -haddock-style: multi-line - -# How to print module docstring -haddock-style-module: null - -# Styling of let blocks (choices: auto, inline, newline, or mixed) -let-style: auto - -# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) -in-style: right-align - -# Whether to put parentheses around a single constraint (choices: auto, always, or never) -single-constraint-parens: always - -# Output Unicode syntax (choices: detect, always, or never) -unicode: never - -# Give the programmer more choice on where to insert blank lines -respectful: true - -# Fixity information for operators -fixities: [] - From 8d51d9d915705c60d6036b8836b612e10920db5f Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 05:33:20 +0200 Subject: [PATCH 3/8] before --- plutus-ledger/package.yaml | 101 ++++++++---------- plutus-ledger/plutus-ledger.cabal | 53 ++++++++- plutus-script-utils/package.yaml | 71 +++++------- plutus-script-utils/plutus-script-utils.cabal | 6 +- .../src/Plutus/Script/Utils/Scripts.hs | 4 +- .../src/Plutus/Script/Utils/V1/Generators.hs | 15 +-- .../src/Plutus/Script/Utils/V1/Scripts.hs | 13 +-- .../src/Plutus/Script/Utils/V2/Generators.hs | 45 ++++---- 8 files changed, 165 insertions(+), 143 deletions(-) diff --git a/plutus-ledger/package.yaml b/plutus-ledger/package.yaml index c3ce1b0..89d3a51 100644 --- a/plutus-ledger/package.yaml +++ b/plutus-ledger/package.yaml @@ -6,70 +6,67 @@ license-file: - LICENSE - NOTICE language: Haskell2010 + default-extensions: + - ConstraintKinds + - DataKinds + - DeriveAnyClass - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable + - DerivingStrategies + - DerivingVia + - EmptyDataDeriving - ExplicitForAll - FlexibleContexts + - FlexibleInstances + - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost + - LambdaCase - MultiParamTypeClasses + - MultiWayIf + - NamedFieldPuns + - NumericUnderscores + - OverloadedStrings + - PolyKinds + - RankNTypes + - RecordWildCards - ScopedTypeVariables - StandaloneDeriving + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - TypeOperators + - ViewPatterns + ghc-options: - - -Wall - - -Wnoncanonical-monad-instances - - -Wno-unused-packages - - -Wincomplete-uni-patterns - - -Wincomplete-record-updates - - -Wredundant-constraints - - -Widentities - - -fobject-code - - -fno-ignore-interface-pragmas - - -fno-omit-interface-pragmas - - -fplugin-opt - - PlutusTx.Plugin:target-version=1.1.0 - - -fplugin-opt - - PlutusTx.Plugin:defer-errors + -Wall + -Wcompat + -Wnoncanonical-monad-instances + -Wno-unused-packages + -Wno-missed-extra-shared-lib + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -fobject-code + -fignore-hpc-changes + -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas + -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 + -fplugin-opt PlutusTx.Plugin:conservative-optimisation + -fplugin-opt PlutusTx.Plugin:defer-errors + +when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false library: source-dirs: src - exposed-modules: - - Data.Aeson.Extras - - Data.Time.Units.Extra - - Ledger - - Ledger.Address - - Ledger.Address.Orphans - - Ledger.AddressMap - - Ledger.Blockchain - - Ledger.Builtins.Orphans - - Ledger.CardanoWallet - - Ledger.Credential.Orphans - - Ledger.Crypto - - Ledger.Crypto.Orphans - - Ledger.DCert.Orphans - - Ledger.Index - - Ledger.Index.Internal - - Ledger.Orphans - - Ledger.Scripts - - Ledger.Scripts.Orphans - - Ledger.Slot - - Ledger.Test - - Ledger.Tx - - Ledger.Tx.CardanoAPI - - Ledger.Tx.CardanoAPI.Internal - - Ledger.Tx.Internal - - Ledger.Tx.Orphans - - Ledger.Tx.Orphans.V1 - - Ledger.Tx.Orphans.V2 - - Ledger.Typed.Scripts.Orphans - - Ledger.Value.CardanoAPI - - Ledger.Value.Orphans - other-modules: - - Codec.CBOR.Extras dependencies: - aeson - base >=4.9 && <5 @@ -89,7 +86,7 @@ library: - flat - hashable - http-api-data - - lens + - optics-core - memory - ordered-containers - plutus-core @@ -104,19 +101,11 @@ library: - text - time-units - vector - when: - - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" - buildable: false tests: plutus-ledger-test: main: Spec.hs source-dirs: test - other-modules: - - Ledger.Tx.CardanoAPISpec - when: - - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" - buildable: false dependencies: - aeson - base >=4.9 && <5 diff --git a/plutus-ledger/plutus-ledger.cabal b/plutus-ledger/plutus-ledger.cabal index a893e81..c4252f8 100644 --- a/plutus-ledger/plutus-ledger.cabal +++ b/plutus-ledger/plutus-ledger.cabal @@ -13,6 +13,7 @@ build-type: Simple library exposed-modules: + Codec.CBOR.Extras Data.Aeson.Extras Data.Time.Units.Extra Ledger @@ -43,24 +44,44 @@ library Ledger.Typed.Scripts.Orphans Ledger.Value.CardanoAPI Ledger.Value.Orphans - other-modules: - Codec.CBOR.Extras hs-source-dirs: src default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable + DerivingStrategies + DerivingVia + EmptyDataDeriving ExplicitForAll FlexibleContexts + FlexibleInstances + GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + LambdaCase MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PolyKinds + RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving - ghc-options: -Wall -Wnoncanonical-monad-instances -Wno-unused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wno-unused-packages -Wno-missed-extra-shared-lib -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fignore-hpc-changes -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:conservative-optimisation -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: aeson , base >=4.9 && <5 @@ -80,8 +101,8 @@ library , flat , hashable , http-api-data - , lens , memory + , optics-core , ordered-containers , plutus-core , plutus-ledger-api @@ -107,19 +128,41 @@ test-suite plutus-ledger-test hs-source-dirs: test default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable + DerivingStrategies + DerivingVia + EmptyDataDeriving ExplicitForAll FlexibleContexts + FlexibleInstances + GADTs GeneralizedNewtypeDeriving ImportQualifiedPost + LambdaCase MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PolyKinds + RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving - ghc-options: -Wall -Wnoncanonical-monad-instances -Wno-unused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wno-unused-packages -Wno-missed-extra-shared-lib -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fignore-hpc-changes -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:conservative-optimisation -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: aeson , base >=4.9 && <5 diff --git a/plutus-script-utils/package.yaml b/plutus-script-utils/package.yaml index a05433d..79e9346 100644 --- a/plutus-script-utils/package.yaml +++ b/plutus-script-utils/package.yaml @@ -6,6 +6,7 @@ license-file: - LICENSE - NOTICE language: Haskell2010 + default-extensions: - ConstraintKinds - DataKinds @@ -18,9 +19,10 @@ default-extensions: - DerivingStrategies - DerivingVia - EmptyDataDeriving + - ExistentialQuantification + - ExplicitForAll - FlexibleContexts - FlexibleInstances - - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase @@ -29,7 +31,6 @@ default-extensions: - NamedFieldPuns - NumericUnderscores - OverloadedStrings - - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables @@ -40,50 +41,31 @@ default-extensions: - TypeFamilies - TypeOperators - ViewPatterns + ghc-options: - - -Wall - - -Wcompat - - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - - -Wnoncanonical-monad-instances - - -Wno-unused-packages - - -Wredundant-constraints - - -Widentities - - -Wmissing-import-lists - - -Wno-missed-extra-shared-lib - - -fobject-code - - -fno-ignore-interface-pragmas - - -fignore-hpc-changes - - -fno-omit-interface-pragmas - - -fplugin-opt - - PlutusTx.Plugin:target-version=1.1.0 - - -fplugin-opt - - PlutusTx.Plugin:defer-errors - - -fplugin-opt - - PlutusTx.Plugin:conservative-optimisation + -Wall + -Wcompat + -Wnoncanonical-monad-instances + -Wno-unused-packages + -Wno-missed-extra-shared-lib + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -Widentities + -fobject-code + -fignore-hpc-changes + -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas + -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 + -fplugin-opt PlutusTx.Plugin:conservative-optimisation + -fplugin-opt PlutusTx.Plugin:defer-errors + +when: + - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" + buildable: false library: source-dirs: src - exposed-modules: - - Plutus.Script.Utils.Address - - Plutus.Script.Utils.Data - - Plutus.Script.Utils.Scripts - - Plutus.Script.Utils.V1 - - Plutus.Script.Utils.V1.Contexts - - Plutus.Script.Utils.V1.Generators - - Plutus.Script.Utils.V1.Scripts - - Plutus.Script.Utils.V1.Typed - - Plutus.Script.Utils.V2 - - Plutus.Script.Utils.V2.Contexts - - Plutus.Script.Utils.V2.Generators - - Plutus.Script.Utils.V2.Scripts - - Plutus.Script.Utils.V2.Typed - - Plutus.Script.Utils.V3 - - Plutus.Script.Utils.V3.Contexts - - Plutus.Script.Utils.V3.Generators - - Plutus.Script.Utils.V3.Typed - - Plutus.Script.Utils.Value - - Prettyprinter.Extras dependencies: - aeson - base >=4.9 && <5 @@ -98,7 +80,4 @@ library: - plutus-tx-plugin - prettyprinter - serialise - - tagged - when: - - condition: "!((impl(ghc >= 9.6) && impl(ghc < 9.7)) || (impl(ghc >= 9.12) && impl(ghc < 9.13)))" - buildable: false + - tagged \ No newline at end of file diff --git a/plutus-script-utils/plutus-script-utils.cabal b/plutus-script-utils/plutus-script-utils.cabal index 1135c0e..8d4aaa2 100644 --- a/plutus-script-utils/plutus-script-utils.cabal +++ b/plutus-script-utils/plutus-script-utils.cabal @@ -46,9 +46,10 @@ library DerivingStrategies DerivingVia EmptyDataDeriving + ExistentialQuantification + ExplicitForAll FlexibleContexts FlexibleInstances - GADTs GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase @@ -57,7 +58,6 @@ library NamedFieldPuns NumericUnderscores OverloadedStrings - PolyKinds RankNTypes RecordWildCards ScopedTypeVariables @@ -68,7 +68,7 @@ library TypeFamilies TypeOperators ViewPatterns - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wno-unused-packages -Wredundant-constraints -Widentities -Wmissing-import-lists -Wno-missed-extra-shared-lib -fobject-code -fno-ignore-interface-pragmas -fignore-hpc-changes -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:conservative-optimisation + ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wno-unused-packages -Wno-missed-extra-shared-lib -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities -fobject-code -fignore-hpc-changes -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 -fplugin-opt PlutusTx.Plugin:conservative-optimisation -fplugin-opt PlutusTx.Plugin:defer-errors build-depends: aeson , base >=4.9 && <5 diff --git a/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs b/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs index 9a1c9bb..5e7578b 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/Scripts.hs @@ -26,7 +26,7 @@ module Plutus.Script.Utils.Scripts where import Cardano.Api qualified as C.Api -import Cardano.Ledger.Plutus.Language (Language (PlutusV1, PlutusV2, PlutusV3)) +import Cardano.Ledger.Plutus.Language (Language (PlutusV1, PlutusV2, PlutusV3, PlutusV4)) import Codec.Serialise (Serialise) import Data.Aeson (FromJSON, ToJSON) import Data.Coerce (coerce) @@ -106,6 +106,7 @@ instance Pretty Language where pretty PlutusV1 = "Plutus V1" pretty PlutusV2 = "Plutus V2" pretty PlutusV3 = "Plutus V3" + pretty PlutusV4 = "Plutus V4" -- | A script of some kind with its Plutus language version data Versioned script = Versioned @@ -123,6 +124,7 @@ instance (ToScript a) => ToCardanoScriptHash (Versioned a) where PlutusV1 -> C.Api.hashScript $ C.Api.PlutusScript C.Api.PlutusScriptV1 $ C.Api.PlutusScriptSerialised script PlutusV2 -> C.Api.hashScript $ C.Api.PlutusScript C.Api.PlutusScriptV2 $ C.Api.PlutusScriptSerialised script PlutusV3 -> C.Api.hashScript $ C.Api.PlutusScript C.Api.PlutusScriptV3 $ C.Api.PlutusScriptSerialised script + PlutusV4 -> C.Api.hashScript $ C.Api.PlutusScript C.Api.PlutusScriptV4 $ C.Api.PlutusScriptSerialised script instance (ToScript a) => ToScript (Versioned a) where toScript = toScript . unversioned diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V1/Generators.hs b/plutus-script-utils/src/Plutus/Script/Utils/V1/Generators.hs index 6de5bee..c7d58b9 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/V1/Generators.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/V1/Generators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} module Plutus.Script.Utils.V1.Generators @@ -58,6 +59,8 @@ import PlutusLedgerApi.V1 ) import PlutusTx qualified import PlutusTx.Builtins.Internal qualified as PlutusTx +import PlutusTx.List +import PlutusTx.Prelude alwaysSucceedValidator :: Validator alwaysSucceedValidator = toValidator $$(PlutusTx.compile [||trueVal||]) @@ -123,9 +126,9 @@ alwaysFailTokenValue = singleton alwaysFailCurrencySymbol -- in the minting transaction. mkForwardingMintingPolicy :: ValidatorHash -> MintingPolicy mkForwardingMintingPolicy vshsh = - toMintingPolicy $ - $$(PlutusTx.compile [||mkUntypedMintingPolicy . forwardToValidator||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh + toMintingPolicy + $ $$(PlutusTx.compile [||mkUntypedMintingPolicy . forwardToValidator||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh where {-# INLINEABLE forwardToValidator #-} forwardToValidator :: ValidatorHash -> () -> ScriptContext -> Bool @@ -139,9 +142,9 @@ mkForwardingMintingPolicy vshsh = -- in the right transaction. mkForwardingStakeValidator :: ValidatorHash -> StakeValidator mkForwardingStakeValidator vshsh = - toStakeValidator $ - $$(PlutusTx.compile [||mkUntypedStakeValidator . forwardToValidator||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh + toStakeValidator + $ $$(PlutusTx.compile [||mkUntypedStakeValidator . forwardToValidator||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh where {-# INLINEABLE forwardToValidator #-} forwardToValidator :: ValidatorHash -> () -> ScriptContext -> Bool diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V1/Scripts.hs b/plutus-script-utils/src/Plutus/Script/Utils/V1/Scripts.hs index 1c4eb7d..402d1f2 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/V1/Scripts.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/V1/Scripts.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} + module Plutus.Script.Utils.V1.Scripts ( UntypedValidator, UntypedStakeValidator, @@ -9,8 +11,7 @@ module Plutus.Script.Utils.V1.Scripts where import PlutusTx (BuiltinData, FromData, fromBuiltinData) -import PlutusTx.Prelude (BuiltinString, BuiltinUnit, check, trace) -import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Prelude (Bool (False), BuiltinString, BuiltinUnit, Maybe, check, fromMaybe, return, trace, ($)) type UntypedValidator = BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit @@ -32,8 +33,8 @@ mkUntypedValidator :: (datum -> redeemer -> scriptContext -> Bool) -> UntypedValidator mkUntypedValidator f d r sc = - check $ - PlutusTx.fromMaybe + check + $ fromMaybe False ( do dat <- tracedSafeFrom "Datum decoded successfully" d @@ -49,8 +50,8 @@ mkUntypedStakeValidator :: (redeemer -> scriptContext -> Bool) -> UntypedStakeValidator mkUntypedStakeValidator f r sc = - check $ - PlutusTx.fromMaybe + check + $ fromMaybe False ( do red <- tracedSafeFrom "Redeemer decoded successfully" r diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V2/Generators.hs b/plutus-script-utils/src/Plutus/Script/Utils/V2/Generators.hs index 3322118..4973bac 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/V2/Generators.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/V2/Generators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -g -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} module Plutus.Script.Utils.V2.Generators @@ -56,20 +57,24 @@ import PlutusLedgerApi.V2 Value, singleton, ) -import PlutusTx qualified -import PlutusTx.Builtins.Internal qualified as PlutusTx +import PlutusTx.Builtins.Internal (error, unitval) +import PlutusTx.Code (unsafeApplyCode) +import PlutusTx.Lift (liftCode) +import PlutusTx.List (any) +import PlutusTx.Prelude (Bool (False), BuiltinData, BuiltinUnit, Integer, ($), (.), (==)) +import PlutusTx.TH (compile) alwaysSucceedValidator :: Validator -alwaysSucceedValidator = toValidator $$(PlutusTx.compile [||trueVal||]) +alwaysSucceedValidator = toValidator $$(compile [||trueVal||]) where - trueVal :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit - trueVal _ _ _ = PlutusTx.unitval + trueVal :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit + trueVal _ _ _ = unitval alwaysFailValidator :: Validator -alwaysFailValidator = toValidator $$(PlutusTx.compile [||falseVal||]) +alwaysFailValidator = toValidator $$(compile [||falseVal||]) where - falseVal :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit - falseVal _ _ _ = PlutusTx.error PlutusTx.unitval + falseVal :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinUnit + falseVal _ _ _ = error unitval alwaysSucceedValidatorVersioned :: Versioned Validator alwaysSucceedValidatorVersioned = Versioned alwaysSucceedValidator PlutusV2 @@ -84,16 +89,16 @@ alwaysFailValidatorHash :: ValidatorHash alwaysFailValidatorHash = toValidatorHash alwaysFailValidatorVersioned alwaysSucceedPolicy :: MintingPolicy -alwaysSucceedPolicy = toMintingPolicy $$(PlutusTx.compile [||trueMP||]) +alwaysSucceedPolicy = toMintingPolicy $$(compile [||trueMP||]) where - trueMP :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit - trueMP _ _ = PlutusTx.unitval + trueMP :: BuiltinData -> BuiltinData -> BuiltinUnit + trueMP _ _ = unitval alwaysFailPolicy :: MintingPolicy -alwaysFailPolicy = toMintingPolicy $$(PlutusTx.compile [||falseMP||]) +alwaysFailPolicy = toMintingPolicy $$(compile [||falseMP||]) where - falseMP :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit - falseMP _ _ = PlutusTx.error PlutusTx.unitval + falseMP :: BuiltinData -> BuiltinData -> BuiltinUnit + falseMP _ _ = error unitval alwaysSucceedPolicyVersioned :: Versioned MintingPolicy alwaysSucceedPolicyVersioned = Versioned alwaysSucceedPolicy PlutusV2 @@ -123,9 +128,9 @@ alwaysFailTokenValue = singleton alwaysFailCurrencySymbol -- in the minting transaction. mkForwardingMintingPolicy :: ValidatorHash -> MintingPolicy mkForwardingMintingPolicy vshsh = - toMintingPolicy $ - $$(PlutusTx.compile [||mkUntypedMintingPolicy . forwardToValidator||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh + toMintingPolicy + $ $$(compile [||mkUntypedMintingPolicy . forwardToValidator||]) + `unsafeApplyCode` liftCode plcVersion100 vshsh where {-# INLINEABLE forwardToValidator #-} forwardToValidator :: ValidatorHash -> () -> ScriptContext -> Bool @@ -139,9 +144,9 @@ mkForwardingMintingPolicy vshsh = -- in the right transaction. mkForwardingStakeValidator :: ValidatorHash -> StakeValidator mkForwardingStakeValidator vshsh = - toStakeValidator $ - $$(PlutusTx.compile [||mkUntypedStakeValidator . forwardToValidator||]) - `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 vshsh + toStakeValidator + $ $$(compile [||mkUntypedStakeValidator . forwardToValidator||]) + `unsafeApplyCode` liftCode plcVersion100 vshsh where {-# INLINEABLE forwardToValidator #-} forwardToValidator :: ValidatorHash -> () -> ScriptContext -> Bool From 1bd99c764a2bc099ed5cb63349fc089f2175dea8 Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 14:01:38 +0200 Subject: [PATCH 4/8] Add Plutus V4 script utils Add `Plutus.Script.Utils.V4` (Contexts, Generators, Typed and the V4 aggregator) mirroring the V3 modules, and revise the multipurpose-script machinery for the V4 ledger API: - Rename the Rewarding purpose to Withdrawing, whose payload is now an `AccountId` instead of a `Credential`. - Add the new Guarding purpose (`GuardingScript Integer (Maybe TopTxInfo)`), with its purpose type, typed-script field, `with/addGuardingPurpose` helpers and `trueGuardingPurpose` generator. - Account for the extra `scriptContextScriptHash` field of V4's `ScriptContext` in the on-chain resolved-context decoder. - Handle V4's distinct `Address` type (account-based staking): match outputs on their payment credential in `Contexts`, use V4's `Address` in `Generators`, and keep building a V1 `Address` in the `ToAddress` instance as the class requires. Bump the index-state and relax the `plutus-ledger-api` upper bound via `allow-newer`, since the cardano stack still caps it below the 1.67+ releases that ship the V4 API (the V1-V3 encodings it consumes are unchanged). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cabal.project | 11 +- plutus-script-utils/plutus-script-utils.cabal | 4 + .../src/Plutus/Script/Utils/V4.hs | 55 ++ .../src/Plutus/Script/Utils/V4/Contexts.hs | 70 +++ .../src/Plutus/Script/Utils/V4/Generators.hs | 361 +++++++++++ .../src/Plutus/Script/Utils/V4/Typed.hs | 568 ++++++++++++++++++ 6 files changed, 1067 insertions(+), 2 deletions(-) create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V4.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V4/Contexts.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V4/Generators.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V4/Typed.hs diff --git a/cabal.project b/cabal.project index ca340e9..b3437dd 100644 --- a/cabal.project +++ b/cabal.project @@ -12,8 +12,8 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee index-state: - , hackage.haskell.org 2026-09-04T06:57:08Z - , cardano-haskell-packages 2026-09-04T06:57:08Z + , hackage.haskell.org 2026-09-29T09:27:39Z + , cardano-haskell-packages 2026-09-24T00:08:56Z packages: plutus-ledger plutus-script-utils @@ -31,6 +31,13 @@ constraints: -- instead of waiting for an upstream bump. allow-newer: , quickcheck-state-machine:random + -- The cardano stack (cardano-api, cardano-ledger-*, ouroboros-consensus) + -- still caps `plutus-ledger-api <1.66`, but Plutus V4's on-chain ledger API + -- only ships from plutus-ledger-api 1.67+. The V1-V3 encodings that the + -- cardano stack actually consumes are unchanged across these releases (only + -- the new V4 API was added), so relax the upper bound instead of waiting for + -- an upstream cardano-api bump. + , *:plutus-ledger-api -- We never, ever, want this. write-ghc-environment-files: never diff --git a/plutus-script-utils/plutus-script-utils.cabal b/plutus-script-utils/plutus-script-utils.cabal index 8d4aaa2..5de690d 100644 --- a/plutus-script-utils/plutus-script-utils.cabal +++ b/plutus-script-utils/plutus-script-utils.cabal @@ -30,6 +30,10 @@ library Plutus.Script.Utils.V3.Contexts Plutus.Script.Utils.V3.Generators Plutus.Script.Utils.V3.Typed + Plutus.Script.Utils.V4 + Plutus.Script.Utils.V4.Contexts + Plutus.Script.Utils.V4.Generators + Plutus.Script.Utils.V4.Typed Plutus.Script.Utils.Value Prettyprinter.Extras hs-source-dirs: diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V4.hs b/plutus-script-utils/src/Plutus/Script/Utils/V4.hs new file mode 100644 index 0000000..3c6aaa3 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V4.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Plutus.Script.Utils.V4 + ( module X, + toCardanoScript, + ) +where + +import Cardano.Api qualified as C.Api +import Plutus.Script.Utils.Address as X +import Plutus.Script.Utils.Data as X +import Plutus.Script.Utils.Scripts as X +import Plutus.Script.Utils.V4.Contexts as X +import Plutus.Script.Utils.V4.Generators as X +import Plutus.Script.Utils.V4.Typed as X +import Plutus.Script.Utils.Value as X + +instance ToValidatorHash Validator where + {-# INLINEABLE toValidatorHash #-} + toValidatorHash = toValidatorHash . (`Versioned` PlutusV4) + +instance ToMintingPolicyHash MintingPolicy where + {-# INLINEABLE toMintingPolicyHash #-} + toMintingPolicyHash = toMintingPolicyHash . (`Versioned` PlutusV4) + +instance ToStakeValidatorHash StakeValidator where + {-# INLINEABLE toStakeValidatorHash #-} + toStakeValidatorHash = toStakeValidatorHash . (`Versioned` PlutusV4) + +instance ToScriptHash Script where + {-# INLINEABLE toScriptHash #-} + toScriptHash = toScriptHash . (`Versioned` PlutusV4) + +instance ToAddress Validator where + {-# INLINEABLE toAddress #-} + toAddress = toAddress . (`Versioned` PlutusV4) + +instance ToCardanoAddress Script where + toCardanoAddress networkId = toCardanoAddress networkId . (`Versioned` PlutusV4) + +instance ToCardanoAddress Validator where + toCardanoAddress networkId = toCardanoAddress networkId . (`Versioned` PlutusV4) + +instance ToCardanoAddress StakeValidator where + toCardanoAddress networkId = toCardanoAddress networkId . (`Versioned` PlutusV4) + +instance ToCardanoAddress MintingPolicy where + toCardanoAddress networkId = toCardanoAddress networkId . (`Versioned` PlutusV4) + +toCardanoScript :: Script -> C.Api.Script C.Api.PlutusScriptV4 +toCardanoScript = + C.Api.PlutusScript C.Api.PlutusScriptV4 + . C.Api.PlutusScriptSerialised + . unScript diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V4/Contexts.hs b/plutus-script-utils/src/Plutus/Script/Utils/V4/Contexts.hs new file mode 100644 index 0000000..ee18efa --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V4/Contexts.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +module Plutus.Script.Utils.V4.Contexts + ( module Contexts, + findTxInByTxOutRef, + findTxRefInByTxOutRef, + outputsAt, + scriptOutputsAt, + valuePaidTo, + ownHash, + ownHashValueAndDatum, + findInput, + ) +where + +import Plutus.Script.Utils.Address (ToCredential (toCredential)) +import Plutus.Script.Utils.Scripts (ToValidatorHash, ValidatorHash (..), toScriptHash, toValidatorHash) +import PlutusLedgerApi.V4 (Address (Address), Credential (ScriptCredential), OutputDatum, ScriptHash (ScriptHash), TxOut (TxOut), TxOutRef, Value) +import PlutusLedgerApi.V4.Contexts as Contexts hiding (findTxInByTxOutRef, valuePaidTo) +import PlutusTx.List (find) +import PlutusTx.Prelude (Maybe (Just), fst, mconcat, traceError, (.), (<$>), (==)) + +{-# INLINEABLE findInput #-} +findInput :: TxOutRef -> [TxInInfo] -> Maybe TxOut +findInput outRef = (txInInfoResolved <$>) . find ((== outRef) . txInInfoOutRef) + +{-# INLINEABLE findTxInByTxOutRef #-} +findTxInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxOut +findTxInByTxOutRef outRef = findInput outRef . txInfoInputs + +{-# INLINEABLE findTxRefInByTxOutRef #-} +findTxRefInByTxOutRef :: TxOutRef -> TxInfo -> Maybe TxOut +findTxRefInByTxOutRef outRef = findInput outRef . txInfoReferenceInputs + +-- | Get the datums and values paid to an address by a pending transaction. +-- Note that, unlike previous ledger versions, PlutusV4 introduces its own +-- 'Address' type (whose staking part is an 'AccountId' rather than a +-- 'StakingCredential'). Since the repository's 'toAddress' produces a V1 +-- 'Address', outputs are matched on their payment 'Credential' instead of on +-- the whole address (staking credentials are ignored, as documented for +-- 'ToAddress'). +{-# INLINEABLE outputsAt #-} +outputsAt :: (ToCredential a) => TxInfo -> a -> [(Value, OutputDatum)] +outputsAt txInfo (toCredential -> cred) = [(val, dat) | TxOut (Address cred' _) val dat _ <- txInfoOutputs txInfo, cred == cred'] + +-- | Get the datums and values paid to an address of a validator by a pending transaction. +{-# INLINEABLE scriptOutputsAt #-} +scriptOutputsAt :: (ToValidatorHash a) => TxInfo -> a -> [(Value, OutputDatum)] +scriptOutputsAt txInfo = outputsAt txInfo . toScriptHash . toValidatorHash + +-- | Get the total value paid to a public key address by a pending transaction. +{-# INLINEABLE valuePaidTo #-} +valuePaidTo :: (ToCredential a) => TxInfo -> a -> Value +valuePaidTo txInfo = mconcat . (fst <$>) . outputsAt txInfo + +-- | Get the validator hash, datum and value of the output that is curently +-- being validated +{-# INLINEABLE ownHashValueAndDatum #-} +ownHashValueAndDatum :: ScriptContext -> (ValidatorHash, Value, OutputDatum) +ownHashValueAndDatum (findOwnInput -> Just (TxInInfo _ (TxOut (Address (ScriptCredential (ScriptHash s)) _) val dat _))) = (ValidatorHash s, val, dat) +ownHashValueAndDatum _ = traceError "Unable to find the own script's input" + +-- | Get the hash of the validator script that is currently being validated. +{-# INLINEABLE ownHash #-} +ownHash :: ScriptContext -> ValidatorHash +ownHash (ownHashValueAndDatum -> (vHash, _, _)) = vHash diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V4/Generators.hs b/plutus-script-utils/src/Plutus/Script/Utils/V4/Generators.hs new file mode 100644 index 0000000..602d5c6 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V4/Generators.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Plutus.Script.Utils.V4.Generators + ( trueCertifyingPurpose, + trueMintingPurpose, + forwardingMintingPurpose, + ownForwardingMintingPurpose, + trueProposingPurpose, + trueWithdrawingPurpose, + trueSpendingPurpose, + forwardingSpendingPurpose, + ownForwardingSpendingPurpose, + trueVotingPurpose, + trueGuardingPurpose, + falseTypedMultiPurposeScript, + trueTypedMultiPurposeScript, + withCertifyingPurpose, + addCertifyingPurpose, + withMintingPurpose, + addMintingPurpose, + withProposingPurpose, + addProposingPurpose, + withWithdrawingPurpose, + addWithdrawingPurpose, + withSpendingPurpose, + addSpendingPurpose, + withVotingPurpose, + addVotingPurpose, + withGuardingPurpose, + addGuardingPurpose, + trueMintingMPScript, + trueSpendingMPScript, + falseMPScript, + trueMPScript, + multiPurposeScriptValue, + ) +where + +import Data.Maybe (Maybe (Just, Nothing), fromMaybe) +import Plutus.Script.Utils.Scripts + ( ScriptHash (ScriptHash), + ToScript (toScript), + ToScriptHash (toScriptHash), + toCurrencySymbol, + ) +import Plutus.Script.Utils.V4.Typed + ( CertifyingPurposeType', + GuardingPurposeType', + MintingPurposeType', + MultiPurposeScript (MultiPurposeScript), + ProposingPurposeType', + SpendingPurposeType', + TypedMultiPurposeScript + ( TypedMultiPurposeScript, + certifyingPurpose, + guardingPurpose, + mintingPurpose, + proposingPurpose, + spendingPurpose, + votingPurpose, + withdrawingPurpose + ), + VotingPurposeType', + WithdrawingPurposeType', + mkMultiPurposeScript, + ) +import PlutusLedgerApi.V4 + ( Credential (ScriptCredential), + CurrencySymbol (CurrencySymbol), + FromData, + MintValue, + TokenName, + TxInInfo (TxInInfo), + TxOut (TxOut), + Value, + mintValueToMap, + singleton, + ) +import PlutusLedgerApi.V4.Address (Address (Address)) +import PlutusTx.AssocMap qualified as Map +import PlutusTx.List (elem) +import PlutusTx.Prelude + ( Bool (False, True), + Eq ((==)), + Integer, + ($), + (&&), + (.), + ) +import PlutusTx.TH (compile) + +trueCertifyingPurpose :: CertifyingPurposeType' red txInfo +trueCertifyingPurpose _ _ _ _ = True + +trueMintingPurpose :: MintingPurposeType' red txInfo +trueMintingPurpose _ _ _ = True + +-- | Minting script that ensures a given spending script is invoked in the transaction +{-# INLINEABLE forwardingMintingPurpose #-} +forwardingMintingPurpose :: (ToScriptHash script) => script -> (mtx -> [TxInInfo]) -> MintingPurposeType' red mtx +forwardingMintingPurpose (toScriptHash -> sHash) toTxInInfos _ _ (toTxInInfos -> txInInfos) = + sHash `elem` [h | TxInInfo _ (TxOut (Address (ScriptCredential h) _) _ _ _) <- txInInfos] + +-- | Minting policy that ensures the own spending script is invoked in the transaction +{-# INLINEABLE ownForwardingMintingPurpose #-} +ownForwardingMintingPurpose :: (mtx -> [TxInInfo]) -> MintingPurposeType' red mtx +ownForwardingMintingPurpose toTxInInfos cs = forwardingMintingPurpose cs toTxInInfos cs + +trueProposingPurpose :: ProposingPurposeType' red txInfo +trueProposingPurpose _ _ _ _ = True + +trueWithdrawingPurpose :: WithdrawingPurposeType' red txInfo +trueWithdrawingPurpose _ _ _ = True + +trueSpendingPurpose :: SpendingPurposeType' dat red txInfo +trueSpendingPurpose _ _ _ _ = True + +-- | Spending script that ensures a given minting script is invoked in the transaction +{-# INLINEABLE forwardingSpendingPurpose #-} +forwardingSpendingPurpose :: (ToScriptHash script) => script -> (txInfo -> MintValue) -> SpendingPurposeType' dat red txInfo +forwardingSpendingPurpose (toScriptHash -> ScriptHash hash) toMintValue _ _ _ (mintValueToMap . toMintValue -> mintValue) = + CurrencySymbol hash `Map.member` mintValue + +-- | Spending purpose that ensures the own minting purpose is invoked in the transaction +{-# INLINEABLE ownForwardingSpendingPurpose #-} +ownForwardingSpendingPurpose :: (txInfo -> MintValue) -> (txInfo -> [TxInInfo]) -> SpendingPurposeType' dat red txInfo +ownForwardingSpendingPurpose toMintValue toTxInInfos oRef dat red txInfo = + case [hash | TxInInfo ref (TxOut (Address (ScriptCredential hash) _) _ _ _) <- toTxInInfos txInfo, ref == oRef] of + [hash] -> forwardingSpendingPurpose hash toMintValue oRef dat red txInfo + _ -> False + +trueVotingPurpose :: VotingPurposeType' red txInfo +trueVotingPurpose _ _ _ = True + +trueGuardingPurpose :: GuardingPurposeType' red txInfo +trueGuardingPurpose _ _ _ _ = True + +-- * Building multi purpose scripts + +{-- Note on building multi-purpose scripts. Multi-purpose scripts are never meant + to be instantiated directly. The rationale is that most script will seldom be + used for more than 2 purposes. Thus it is more convient to start from a + default instance and build up the script from there. To that end, we provide + three facilities: + + - 2 default instances, one that say No for every purpose, and one that says + Yes for every purpose. Most likely, the former will be the right starting + point in almost every cases. + + - Helpers @withXXXpurpose@ to override a given purpose + + - Helpers @addXXXpurpose@ to add constraints to an existing purpose. While + this can be detrimental to use this when the parameters need to be + deserialized in several constraints, it can prove useful when working with + several unrelated constraints. Using this is left at the user's discretion. + + Example: if you want a script that fails for all purposes but spending and + always succeeds otherwise, use: + @falseTypedMultiPurposeScript `withSpendingPurpose` trueSpendingPurpose@ + +--} + +falseTypedMultiPurposeScript :: TypedMultiPurposeScript () () () () () () () () () () () () () () () +falseTypedMultiPurposeScript = + TypedMultiPurposeScript + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +trueTypedMultiPurposeScript :: TypedMultiPurposeScript () () () () () () () () () () () () () () () +trueTypedMultiPurposeScript = + TypedMultiPurposeScript + (Just trueCertifyingPurpose) + (Just trueMintingPurpose) + (Just trueProposingPurpose) + (Just trueWithdrawingPurpose) + (Just trueSpendingPurpose) + (Just trueVotingPurpose) + (Just trueGuardingPurpose) + +-- | Overrides the certifying purpose +withCertifyingPurpose :: + (FromData cr', FromData ctx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + CertifyingPurposeType' cr' ctx' -> + TypedMultiPurposeScript cr' ctx' mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +withCertifyingPurpose ts cs = ts {certifyingPurpose = Just cs} + +-- | Combines a new certifying purpose with the existing one +addCertifyingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + CertifyingPurposeType' cr ctx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addCertifyingPurpose ts@(TypedMultiPurposeScript {certifyingPurpose}) cs = + ts `withCertifyingPurpose` \ix cert red txInfo -> + fromMaybe trueCertifyingPurpose certifyingPurpose ix cert red txInfo + && cs ix cert red txInfo + +-- | Overrides the certifying purpose +withMintingPurpose :: + (FromData mr', FromData mtx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + MintingPurposeType' mr' mtx' -> + TypedMultiPurposeScript cr ctx mr' mtx' pr ptx wr wtx sd sr stx vr vtx gr gtx +withMintingPurpose ts ms = ts {mintingPurpose = Just ms} + +-- | Combines a new minting purpose with the existing one +addMintingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + MintingPurposeType' mr mtx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addMintingPurpose ts@(TypedMultiPurposeScript {mintingPurpose}) ms = + ts `withMintingPurpose` \cs red txInfo -> + fromMaybe trueMintingPurpose mintingPurpose cs red txInfo + && ms cs red txInfo + +-- | Overrides the proposing purpose +withProposingPurpose :: + (FromData pr', FromData ptx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + ProposingPurposeType' pr' ptx' -> + TypedMultiPurposeScript cr ctx mr mtx pr' ptx' wr wtx sd sr stx vr vtx gr gtx +withProposingPurpose ts ps = ts {proposingPurpose = Just ps} + +-- | Combines a new proposing purpose with the existing one +addProposingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + ProposingPurposeType' pr ptx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addProposingPurpose ts@(TypedMultiPurposeScript {proposingPurpose}) ps = + ts `withProposingPurpose` \ix prop red txInfo -> + fromMaybe trueProposingPurpose proposingPurpose ix prop red txInfo + && ps ix prop red txInfo + +-- | Overrides the withdrawing purpose +withWithdrawingPurpose :: + (FromData wr', FromData wtx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + WithdrawingPurposeType' wr' wtx' -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr' wtx' sd sr stx vr vtx gr gtx +withWithdrawingPurpose ts ws = ts {withdrawingPurpose = Just ws} + +-- | Combines a new withdrawing purpose with the existing one +addWithdrawingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + WithdrawingPurposeType' wr wtx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addWithdrawingPurpose ts@(TypedMultiPurposeScript {withdrawingPurpose}) ws = + ts `withWithdrawingPurpose` \accId red txInfo -> + fromMaybe trueWithdrawingPurpose withdrawingPurpose accId red txInfo + && ws accId red txInfo + +-- | Overrides the spending purpose +withSpendingPurpose :: + (FromData sd', FromData sr', FromData stx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + SpendingPurposeType' sd' sr' stx' -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd' sr' stx' vr vtx gr gtx +withSpendingPurpose ts ss = ts {spendingPurpose = Just ss} + +-- | Combines a new spending purpose with the existing one +addSpendingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + SpendingPurposeType' sd sr stx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addSpendingPurpose ts@(TypedMultiPurposeScript {spendingPurpose}) ss = + ts `withSpendingPurpose` \oRef mDat red txInfo -> + fromMaybe trueSpendingPurpose spendingPurpose oRef mDat red txInfo + && ss oRef mDat red txInfo + +-- | Overrides the voting purpose +withVotingPurpose :: + (FromData vr', FromData vtx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + VotingPurposeType' vr' vtx' -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr' vtx' gr gtx +withVotingPurpose ts vs = ts {votingPurpose = Just vs} + +-- | Combines a new voting purpose with the existing one +addVotingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + VotingPurposeType' vr vtx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addVotingPurpose ts@(TypedMultiPurposeScript {votingPurpose}) vs = + ts `withVotingPurpose` \voter red txInfo -> + fromMaybe trueVotingPurpose votingPurpose voter red txInfo + && vs voter red txInfo + +-- | Overrides the guarding purpose +withGuardingPurpose :: + (FromData gr', FromData gtx') => + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + GuardingPurposeType' gr' gtx' -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr' gtx' +withGuardingPurpose ts gs = ts {guardingPurpose = Just gs} + +-- | Combines a new guarding purpose with the existing one +addGuardingPurpose :: + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx -> + GuardingPurposeType' gr gtx -> + TypedMultiPurposeScript cr ctx mr mtx pr ptx wr wtx sd sr stx vr vtx gr gtx +addGuardingPurpose ts@(TypedMultiPurposeScript {guardingPurpose}) gs = + ts `withGuardingPurpose` \ix mTopTxInfo red txInfo -> + fromMaybe trueGuardingPurpose guardingPurpose ix mTopTxInfo red txInfo + && gs ix mTopTxInfo red txInfo + +-- * Creating and compiling multi-purpose scripts + +{-- Note on creating and compiling multi-purpose scripts: We provide two examples + below to showcase how one can go from their abstract script reprentation to a + compiled plutus scripts. The steps are as follows: + + 1. Start from an existing template, such as @falseTypedMultiPurposeScript@ + + 2. Define the typed logics for the necessary purposes + + 3. Assign these logics within the template + + 4. Generate the script from the typed template + + 5. Compile the script and wrap it into a @MultiPurposeScript@ enveloppe + +--} + +-- | The multi-purpose script that returns @True@ in minting purpose and @False@ +-- otherwise +trueMintingMPScript :: MultiPurposeScript a +trueMintingMPScript = MultiPurposeScript $ toScript $$(compile [||script||]) + where + script = + mkMultiPurposeScript + $ falseTypedMultiPurposeScript + `withMintingPurpose` (trueMintingPurpose @() @()) + +-- | The multi-purpose script that returns @True@ in spending purpose and @False@ +-- otherwise +trueSpendingMPScript :: MultiPurposeScript a +trueSpendingMPScript = MultiPurposeScript $ toScript $$(compile [||script||]) + where + script = + mkMultiPurposeScript + $ falseTypedMultiPurposeScript + `withSpendingPurpose` trueSpendingPurpose @() @() @() + +-- | The multi-purpose script that returns @True@ in all purposes +trueMPScript :: MultiPurposeScript a +trueMPScript = MultiPurposeScript $ toScript $$(compile [||script||]) + where + script = mkMultiPurposeScript trueTypedMultiPurposeScript + +falseMPScript :: MultiPurposeScript a +falseMPScript = MultiPurposeScript $ toScript $$(compile [||script||]) + where + script = mkMultiPurposeScript falseTypedMultiPurposeScript + +multiPurposeScriptValue :: MultiPurposeScript a -> TokenName -> Integer -> Value +multiPurposeScriptValue mpScript = singleton (toCurrencySymbol mpScript) diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V4/Typed.hs b/plutus-script-utils/src/Plutus/Script/Utils/V4/Typed.hs new file mode 100644 index 0000000..b697aa4 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V4/Typed.hs @@ -0,0 +1,568 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Plutus.Script.Utils.V4.Typed + ( ConnectionError (..), + WrongOutTypeError (..), + checkMultiPurposeScriptAddress, + checkDatum, + TypedScriptTxOut (..), + TypedScriptTxOutRef (..), + makeTypedScriptTxOut, + typeScriptTxOut, + typeScriptTxOutRef, + MultiPurposeScriptTypes (..), + MultiPurposeScript (..), + generalise, + Any, + toCardanoAddressAny, + IsDataDatum, + TypedMultiPurposeScript (..), + mkMultiPurposeScript, + CertifyingPurposeType', + MintingPurposeType', + ProposingPurposeType', + WithdrawingPurposeType', + SpendingPurposeType', + VotingPurposeType', + GuardingPurposeType', + CertifyingPurposeType, + MintingPurposeType, + ProposingPurposeType, + WithdrawingPurposeType, + SpendingPurposeType, + VotingPurposeType, + GuardingPurposeType, + ) +where + +import Cardano.Api qualified as C.Api +import Codec.Serialise (Serialise) +import Control.Monad (unless) +import Control.Monad.Except + ( MonadError, + throwError, + ) +import Data.Coerce (coerce) +import Data.Kind (Type) +import Data.Void (Void) +import GHC.Generics (Generic) +import Plutus.Script.Utils.Address + ( ToAddress (toAddress), + ToCardanoAddress (toCardanoAddress), + ToCredential (toCredential), + ) +import Plutus.Script.Utils.Data (datumHash) +import Plutus.Script.Utils.Scripts + ( Language (PlutusV4), + MintingPolicy (MintingPolicy), + Script, + StakeValidator (StakeValidator), + ToMintingPolicy (toMintingPolicy), + ToMintingPolicyHash (toMintingPolicyHash), + ToScript (toScript), + ToScriptHash (toScriptHash), + ToStakeValidator (toStakeValidator), + ToStakeValidatorHash (toStakeValidatorHash), + ToValidator (toValidator), + ToValidatorHash (toValidatorHash), + ToVersioned (toVersioned), + Validator (Validator), + ValidatorHash (ValidatorHash), + Versioned (Versioned), + ) +import Plutus.Script.Utils.V1.Typed + ( Any, + ConnectionError + ( NoDatum, + UnknownRef, + WrongCredentialType, + WrongDatumType, + WrongRedeemerType, + WrongValidatorHash, + WrongValidatorType + ), + WrongOutTypeError + ( ExpectedPubkeyGotScript, + ExpectedScriptGotPubkey + ), + ) +import PlutusLedgerApi.V1 qualified as V1 +import PlutusLedgerApi.V4 + ( AccountId, + Address (Address, addressCredential), + BuiltinData, + Credential (PubKeyCredential, ScriptCredential), + CurrencySymbol, + Datum (Datum), + FromData, + OutputDatum (OutputDatum, OutputDatumHash), + ProposalProcedure, + ScriptHash (ScriptHash), + ScriptInfo (CertifyingScript, GuardingScript, MintingScript, ProposingScript, SpendingScript, VotingScript, WithdrawingScript), + ToData (toBuiltinData), + TopTxInfo, + TxCert, + TxId (TxId), + TxInfo, + TxOut (TxOut), + TxOutRef (TxOutRef), + Value, + Voter, + ) +import PlutusTx + ( FromData (fromBuiltinData), + unstableMakeIsData, + ) +import PlutusTx.Prelude (BuiltinString, BuiltinUnit, check, trace, traceError) +import PlutusTx.Prelude qualified as PlutusTx +import Prettyprinter qualified as PP +import Prettyprinter.Extras qualified as PP + +-- * Type family representing all the necessary types for a 'MultiPurposeScript' + +{-- Note on @MultipPurposeScriptTypes a@. While this type class is useful to + gather all the possible type information of a multi-purpose script, and to + benefit from their default instances, the Plutus compiler is unable to process + type families directly. In particular, @TypedMultiPurposeScript@ cannot be + indexed by a certain @a@ and is instead indexed by all the type components + directly, which is sadly inconvenient. For conveniency reasons, we do provide + @IndexedTypedMultiPurposeScript@ as a constrained instance of + @TypedMultiPurposeScript@ which can be used at an abstract level of script + definition. Note of our helpers and tools can take these directly as inputs + though, or the Plutus compiler will complain about irreducible type + families. --} + +class MultiPurposeScriptTypes a where + -- Certifying purpose type variables with default + type CertifyingRedeemerType a + type CertifyingTxInfoType a + + type CertifyingRedeemerType a = () + type CertifyingTxInfoType a = TxInfo + + -- Minting purpose type variables with default + type MintingRedeemerType a + type MintingTxInfoType a + + type MintingRedeemerType a = () + type MintingTxInfoType a = TxInfo + + -- Proposing purpose type variables with default + type ProposingRedeemerType a + type ProposingTxInfoType a + + type ProposingRedeemerType a = () + type ProposingTxInfoType a = TxInfo + + -- Withdrawing purpose type variables with default + type WithdrawingRedeemerType a + type WithdrawingTxInfoType a + + type WithdrawingRedeemerType a = () + type WithdrawingTxInfoType a = TxInfo + + -- Guarding purpose type variables with default + type GuardingRedeemerType a + type GuardingTxInfoType a + + type GuardingRedeemerType a = () + type GuardingTxInfoType a = TxInfo + + -- Spending purpose type variables with default + type SpendingRedeemerType a + type SpendingTxInfoType a + type SpendingDatumType a + + type SpendingRedeemerType a = () + type SpendingTxInfoType a = TxInfo + type SpendingDatumType a = () + + -- Voting purpose type variables with default + type VotingRedeemerType a + type VotingTxInfoType a + + type VotingRedeemerType a = () + type VotingTxInfoType a = TxInfo + +instance MultiPurposeScriptTypes () + +instance MultiPurposeScriptTypes Void where + type CertifyingRedeemerType Void = Void + type MintingRedeemerType Void = Void + type ProposingRedeemerType Void = Void + type WithdrawingRedeemerType Void = Void + type GuardingRedeemerType Void = Void + type SpendingRedeemerType Void = Void + type SpendingDatumType Void = Void + type VotingRedeemerType Void = Void + +instance MultiPurposeScriptTypes Any where + type CertifyingRedeemerType Any = BuiltinData + type MintingRedeemerType Any = BuiltinData + type ProposingRedeemerType Any = BuiltinData + type WithdrawingRedeemerType Any = BuiltinData + type GuardingRedeemerType Any = BuiltinData + type SpendingRedeemerType Any = BuiltinData + type SpendingDatumType Any = BuiltinData + type VotingRedeemerType Any = BuiltinData + +-- * Various script purposes + +{-- Note on types for the script purposes: Each script purpose is associated with + a given function type with the following characteristics: + + - These purposes return a boolean which corresponds to the validation result + + - These purposes all take a redeemer of a dedicated type, which varies between + the various purposes. Having a custom type here is mandatory because the + concrete redeemer type is only known by the user. It also allows to + customize the way deserialization of the redeemer is performed. + + - The purposes all take a view on the @TxInfo@ from Plutus as parameter. This + type is also custom (although it is expected that it will be TxInfo itself + in some cases) to allows users to perform partial deserialization of the + TxInfo. It happens very seldom that all the fields of the TxInfo are + actually useful for a given script and this is advises to use a custom type + there instead of TxInfo itself. + + - The purposes all take additional parameters based on what can be retrieved + from the @scriptContextScriptInfo@ of the script context (which has to be + deserialized). For instance, a minting purpose will receive its own currency + symbol as a parameter. + + - The spending purpose takes an optional datum among these additional + parameters which, similarly to the transaction info and redeemer, is given a + generic type. +--} + +-- | Certifying scripts take an index, certificate, redeemer and txInfo +type CertifyingPurposeType' red txInfo = Integer -> TxCert -> red -> txInfo -> Bool + +type CertifyingPurposeType a = CertifyingPurposeType' (CertifyingRedeemerType a) (CertifyingTxInfoType a) + +-- | Minting scripts take their own currency symbol, redeemer and txInfo +type MintingPurposeType' red txInfo = CurrencySymbol -> red -> txInfo -> Bool + +type MintingPurposeType a = MintingPurposeType' (MintingRedeemerType a) (MintingTxInfoType a) + +-- | Proposing scripts take an index, proposal, redeemer and txInfo +type ProposingPurposeType' red txInfo = Integer -> ProposalProcedure -> red -> txInfo -> Bool + +type ProposingPurposeType a = ProposingPurposeType' (ProposingRedeemerType a) (ProposingTxInfoType a) + +-- | Withdrawing scripts take an account id, redeemer and txInfo +type WithdrawingPurposeType' red txInfo = AccountId -> red -> txInfo -> Bool + +type WithdrawingPurposeType a = WithdrawingPurposeType' (WithdrawingRedeemerType a) (WithdrawingTxInfoType a) + +-- | Spending scripts take the utxo being consumed, an optional datum, redeemer and txInfo +type SpendingPurposeType' dat red txInfo = TxOutRef -> Maybe dat -> red -> txInfo -> Bool + +type SpendingPurposeType a = SpendingPurposeType' (SpendingDatumType a) (SpendingRedeemerType a) (SpendingTxInfoType a) + +-- | Voting scripts take a voter, redeemer and txInfo +type VotingPurposeType' red txInfo = Voter -> red -> txInfo -> Bool + +type VotingPurposeType a = VotingPurposeType' (VotingRedeemerType a) (VotingTxInfoType a) + +-- | Guarding scripts take an index, an optional top-level txInfo, redeemer and txInfo +type GuardingPurposeType' red txInfo = Integer -> Maybe TopTxInfo -> red -> txInfo -> Bool + +type GuardingPurposeType a = GuardingPurposeType' (GuardingRedeemerType a) (GuardingTxInfoType a) + +-- * Typed multi-purpose scripts + +-- | Typed multi-purpose scripts provide 7 different purposes, each with their +-- own types as described above. +data + TypedMultiPurposeScript + certifyingRed + certifyingTxInfo + mintingRed + mintingTxInfo + proposingRed + proposingTxInfo + withdrawingRed + withdrawingTxInfo + spendingDat + spendingRed + spendingTxInfo + votingRed + votingTxInfo + guardingRed + guardingTxInfo + = ( FromData certifyingRed, + FromData certifyingTxInfo, + FromData mintingRed, + FromData mintingTxInfo, + FromData proposingRed, + FromData proposingTxInfo, + FromData withdrawingRed, + FromData withdrawingTxInfo, + FromData spendingDat, + FromData spendingRed, + FromData spendingTxInfo, + FromData votingRed, + FromData votingTxInfo, + FromData guardingRed, + FromData guardingTxInfo + ) => + TypedMultiPurposeScript + { certifyingPurpose :: Maybe (CertifyingPurposeType' certifyingRed certifyingTxInfo), + mintingPurpose :: Maybe (MintingPurposeType' mintingRed mintingTxInfo), + proposingPurpose :: Maybe (ProposingPurposeType' proposingRed proposingTxInfo), + withdrawingPurpose :: Maybe (WithdrawingPurposeType' withdrawingRed withdrawingTxInfo), + spendingPurpose :: Maybe (SpendingPurposeType' spendingDat spendingRed spendingTxInfo), + votingPurpose :: Maybe (VotingPurposeType' votingRed votingTxInfo), + guardingPurpose :: Maybe (GuardingPurposeType' guardingRed guardingTxInfo) + } + +-- * Compiled multi-purpose scripts + +-- | A 'MultiPurposeScript' is a 'Script' with a phantom connection type +newtype MultiPurposeScript (a :: Type) = MultiPurposeScript {getMultiPurposeScript :: Script} + deriving stock (Generic) + deriving newtype (Eq, Ord, Serialise) + deriving (PP.Pretty) via (PP.PrettyShow (MultiPurposeScript a)) + +instance Show (MultiPurposeScript a) where + show = ("Multi-purpose script #" <>) . show . toScriptHash + +instance ToScript (MultiPurposeScript a) where + toScript = getMultiPurposeScript + +instance ToVersioned Script (MultiPurposeScript a) where + toVersioned = (`Versioned` PlutusV4) . toScript + +instance ToScriptHash (MultiPurposeScript a) where + toScriptHash = toScriptHash . toVersioned @Script + +instance ToCredential (MultiPurposeScript a) where + toCredential = ScriptCredential . toScriptHash + +instance ToAddress (MultiPurposeScript a) where + toAddress = (`V1.Address` Nothing) . toCredential + +instance ToValidator (MultiPurposeScript a) where + toValidator = Validator . toScript + +instance ToVersioned Validator (MultiPurposeScript a) where + toVersioned = (`Versioned` PlutusV4) . toValidator + +instance ToValidatorHash (MultiPurposeScript a) where + toValidatorHash = toValidatorHash . toScriptHash + +instance ToMintingPolicy (MultiPurposeScript a) where + toMintingPolicy = MintingPolicy . toScript + +instance ToVersioned MintingPolicy (MultiPurposeScript a) where + toVersioned = (`Versioned` PlutusV4) . MintingPolicy . toScript + +instance ToMintingPolicyHash (MultiPurposeScript a) where + toMintingPolicyHash = toMintingPolicyHash . toScriptHash + +instance ToStakeValidator (MultiPurposeScript a) where + toStakeValidator = StakeValidator . toScript + +instance ToVersioned StakeValidator (MultiPurposeScript a) where + toVersioned = (`Versioned` PlutusV4) . StakeValidator . toScript + +instance ToStakeValidatorHash (MultiPurposeScript a) where + toStakeValidatorHash = toStakeValidatorHash . toScriptHash + +instance ToCardanoAddress (MultiPurposeScript a) where + toCardanoAddress networkId = toCardanoAddress networkId . toVersioned @Script + +toCardanoAddressAny :: C.Api.NetworkId -> MultiPurposeScript a -> C.Api.AddressAny +toCardanoAddressAny nid tv = + case toCardanoAddress nid tv of + C.Api.AddressInEra C.Api.ShelleyAddressInEra {} addr -> C.Api.AddressShelley addr + C.Api.AddressInEra C.Api.ByronAddressInAnyEra {} addr -> C.Api.AddressByron addr + +-- | Generalise the multi-purpose script to one that works with the 'Data' type. +-- we can do this safely because the on-chain validators are untyped, so they +-- always take 'BuiltinData' arguments. The validator script stays the same, so +-- the conversion from 'BuiltinData' to 'a' still takes place, even if it's not +-- reflected in the type signature anymore. +generalise :: MultiPurposeScript a -> MultiPurposeScript Any +generalise = coerce + +-- * From 'TypedMultiPurposeScript' to 'MultiPurposeScript' + +{-- Note on converting 'TypedMultiPurposeScript' to their on-chain representation: + 'TypedMultiPurposeScript' is an abstraction over actual scripts. It splits the + various purposes into manageable entities. However, the on-chain script is a + single function from 'BuiltinData' to 'BuiltinUnit'. In order to convert the + former to the latter, we follow these two steps: + + - We define a custom script context where only the script info is + deserialized, minimizing the cost and leaving to the various purpose the + opportunity to handle the deserialization of the @TxInfo@ the way they require. + + - We define a function 'mkMultiPurposeScript' which wraps the various purposes + into an actual script. The function deserializes the script info, case + splits on it and delegates the work to the right script purpose. On the way, + some tracing is performed when errors occurs, tracing that will be erased by + the plutus compiler by default but can be kept if needed. + +--} + +-- | Custom script context to retrieve the script info. Note that PlutusV4's +-- 'ScriptContext' carries an additional 'scriptContextScriptHash' field, which +-- must be present here so that the 'Data' decoding matches the on-chain layout. +data ScriptContextResolvedScriptInfo = ScriptContextResolvedScriptInfo + { scriptContextTxInfo :: BuiltinData, + scriptContextRedeemer :: BuiltinData, + scriptContextScriptInfo :: ScriptInfo, + scriptContextScriptHash :: BuiltinData + } + +unstableMakeIsData ''ScriptContextResolvedScriptInfo + +{-# INLINEABLE mkMultiPurposeScript #-} +mkMultiPurposeScript :: + TypedMultiPurposeScript cRed cTxInfo mRed mTxInfo pRed pTxInfo wRed wTxInfo sDat sRed sTxInfo vRed vTxInfo gRed gTxInfo -> BuiltinData -> BuiltinUnit +mkMultiPurposeScript TypedMultiPurposeScript {..} dat = + either traceError check $ do + ScriptContextResolvedScriptInfo {..} <- fromBuiltinDataEither "script info" dat + case scriptContextScriptInfo of + CertifyingScript i cert | Just cPurpose <- certifyingPurpose -> do + (red, txInfo) <- deserializeContext "certifying" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Certifying" $ cPurpose i cert red txInfo + CertifyingScript {} -> traceError "Unsupported purpose: Certifying" + MintingScript cur | Just mPurpose <- mintingPurpose -> do + (red, txInfo) <- deserializeContext "minting" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Minting" $ mPurpose cur red txInfo + MintingScript {} -> traceError "Unsupported purpose: Minting" + ProposingScript i prop | Just pPurpose <- proposingPurpose -> do + (red, txInfo) <- deserializeContext "proposing" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Proposing" $ pPurpose i prop red txInfo + ProposingScript {} -> traceError "Unsupported purpose: Proposing" + WithdrawingScript accId | Just wPurpose <- withdrawingPurpose -> do + (red, txInfo) <- deserializeContext "withdrawing" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Withdrawing" $ wPurpose accId red txInfo + WithdrawingScript {} -> traceError "Unsupported purpose: Withdrawing" + SpendingScript oRef mDat | Just sPurpose <- spendingPurpose -> do + (red, txInfo) <- deserializeContext "spending" scriptContextRedeemer scriptContextTxInfo + mResolvedDat <- case mDat of + Nothing -> return Nothing + Just (Datum bDat) -> Just <$> fromBuiltinDataEither "datum" bDat + return $ traceRunning "Spending" $ sPurpose oRef mResolvedDat red txInfo + SpendingScript {} -> traceError "Unsupported purpose: Spending" + VotingScript voter | Just vPurpose <- votingPurpose -> do + (red, txInfo) <- deserializeContext "voting" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Voting" $ vPurpose voter red txInfo + VotingScript {} -> traceError "Unsupported purpose: Voting" + GuardingScript i mTopTxInfo | Just gPurpose <- guardingPurpose -> do + (red, txInfo) <- deserializeContext "guarding" scriptContextRedeemer scriptContextTxInfo + return $ traceRunning "Guarding" $ gPurpose i mTopTxInfo red txInfo + GuardingScript {} -> traceError "Unsupported purpose: Guarding" + where + fromBuiltinDataEither :: (FromData a) => BuiltinString -> BuiltinData -> Either BuiltinString a + fromBuiltinDataEither name = maybe (Left $ "Error when deserializing the " PlutusTx.<> name) Right . fromBuiltinData + + traceRunning :: BuiltinString -> Bool -> Bool + traceRunning name = trace ("Running the validator with the " PlutusTx.<> name PlutusTx.<> " script purpose") + + deserializeContext :: (FromData a, FromData b) => BuiltinString -> BuiltinData -> BuiltinData -> Either BuiltinString (a, b) + deserializeContext name redData txInfoData = do + red <- fromBuiltinDataEither (name PlutusTx.<> " redeemer") redData + txInfo <- fromBuiltinDataEither (name PlutusTx.<> " tx info") txInfoData + return (red, txInfo) + +-- * Checks around typed multi-purpose scripts + +-- | Checks that the given validator hash is consistent with the actual validator. +checkMultiPurposeScriptAddress :: + (MonadError ConnectionError m) => MultiPurposeScript a -> Address -> m () +checkMultiPurposeScriptAddress (toScriptHash -> ScriptHash mpScriptHash) (Address (ScriptCredential (ScriptHash sHash)) _) = + unless (sHash == mpScriptHash) $ + throwError $ + WrongValidatorHash (ValidatorHash mpScriptHash) (ValidatorHash sHash) +checkMultiPurposeScriptAddress _ _ = throwError $ WrongCredentialType ExpectedScriptGotPubkey + +-- | Checks that the given datum has the right type. +checkDatum :: + (FromData (SpendingDatumType a), MonadError ConnectionError m) => + MultiPurposeScript a -> + Datum -> + m (SpendingDatumType a) +checkDatum _ (Datum d) = + case fromBuiltinData d of + Just v -> pure v + Nothing -> throwError $ WrongDatumType d + +type IsDataDatum a = (FromData (SpendingDatumType a), ToData (SpendingDatumType a)) + +-- | A 'TxOut' tagged by a phantom type: and the connection type of the output. +data TypedScriptTxOut a + = (IsDataDatum a) => + TypedScriptTxOut + { tyTxOutTxOut :: TxOut, + tyTxOutData :: SpendingDatumType a + } + +deriving instance (Eq (SpendingDatumType a)) => Eq (TypedScriptTxOut a) + +-- | Create a 'TypedScriptTxOut' from a correctly-typed data script, an address, and a value. +makeTypedScriptTxOut :: + (IsDataDatum out) => + MultiPurposeScript out -> + SpendingDatumType out -> + Value -> + TypedScriptTxOut out +makeTypedScriptTxOut (toScriptHash -> mpScriptHash) dat val = + TypedScriptTxOut + ( TxOut + (Address (ScriptCredential mpScriptHash) Nothing) + val + (OutputDatumHash $ datumHash $ Datum $ toBuiltinData dat) + Nothing + ) + dat + +-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts. +typeScriptTxOut :: + (IsDataDatum out, MonadError ConnectionError m) => + MultiPurposeScript out -> + TxOutRef -> + TxOut -> + Datum -> + m (TypedScriptTxOut out) +typeScriptTxOut mp (TxOutRef (TxId txId) ix) txOut@(TxOut addr _ dat _) datum = + case addressCredential addr of + PubKeyCredential _ -> + throwError $ WrongCredentialType ExpectedScriptGotPubkey + ScriptCredential _vh -> + case dat of + OutputDatum d + | datumHash datum == datumHash d -> + checkMultiPurposeScriptAddress mp addr + >> TypedScriptTxOut txOut <$> checkDatum mp datum + OutputDatumHash dh + | datumHash datum == dh -> + checkMultiPurposeScriptAddress mp addr + >> TypedScriptTxOut txOut <$> checkDatum mp datum + _ -> throwError $ NoDatum (V1.TxOutRef (V1.TxId txId) ix) (datumHash datum) + +-- | A 'TxOutRef' tagged by a phantom type: and the connection type of the output. +data TypedScriptTxOutRef a = TypedScriptTxOutRef + { tyTxOutRefRef :: TxOutRef, + tyTxOutRefOut :: TypedScriptTxOut a + } + +deriving instance (Eq (SpendingDatumType a)) => Eq (TypedScriptTxOutRef a) + +-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts. +typeScriptTxOutRef :: + ( FromData (SpendingDatumType out), + ToData (SpendingDatumType out), + MonadError ConnectionError m + ) => + MultiPurposeScript out -> + TxOutRef -> + TxOut -> + Datum -> + m (TypedScriptTxOutRef out) +typeScriptTxOutRef mp txOutRef txOut datum = + TypedScriptTxOutRef txOutRef <$> typeScriptTxOut mp txOutRef txOut datum From d3d2bdb2d987f9936a40013750469a8a186c8708 Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 14:29:45 +0200 Subject: [PATCH 5/8] Add on-chain ShowBS pretty-printing for script contexts (V1-V4) Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- plutus-script-utils/plutus-script-utils.cabal | 5 + .../src/Plutus/Script/Utils/ShowBS.hs | 238 ++++++++++++++++++ .../src/Plutus/Script/Utils/V1/ShowBS.hs | 88 +++++++ .../src/Plutus/Script/Utils/V2/ShowBS.hs | 70 ++++++ .../src/Plutus/Script/Utils/V3/ShowBS.hs | 190 ++++++++++++++ .../src/Plutus/Script/Utils/V4/ShowBS.hs | 232 +++++++++++++++++ 6 files changed, 823 insertions(+) create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/ShowBS.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V1/ShowBS.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V2/ShowBS.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V3/ShowBS.hs create mode 100644 plutus-script-utils/src/Plutus/Script/Utils/V4/ShowBS.hs diff --git a/plutus-script-utils/plutus-script-utils.cabal b/plutus-script-utils/plutus-script-utils.cabal index 5de690d..cfeb47a 100644 --- a/plutus-script-utils/plutus-script-utils.cabal +++ b/plutus-script-utils/plutus-script-utils.cabal @@ -16,23 +16,28 @@ library Plutus.Script.Utils.Address Plutus.Script.Utils.Data Plutus.Script.Utils.Scripts + Plutus.Script.Utils.ShowBS Plutus.Script.Utils.V1 Plutus.Script.Utils.V1.Contexts Plutus.Script.Utils.V1.Generators Plutus.Script.Utils.V1.Scripts + Plutus.Script.Utils.V1.ShowBS Plutus.Script.Utils.V1.Typed Plutus.Script.Utils.V2 Plutus.Script.Utils.V2.Contexts Plutus.Script.Utils.V2.Generators Plutus.Script.Utils.V2.Scripts + Plutus.Script.Utils.V2.ShowBS Plutus.Script.Utils.V2.Typed Plutus.Script.Utils.V3 Plutus.Script.Utils.V3.Contexts Plutus.Script.Utils.V3.Generators + Plutus.Script.Utils.V3.ShowBS Plutus.Script.Utils.V3.Typed Plutus.Script.Utils.V4 Plutus.Script.Utils.V4.Contexts Plutus.Script.Utils.V4.Generators + Plutus.Script.Utils.V4.ShowBS Plutus.Script.Utils.V4.Typed Plutus.Script.Utils.Value Prettyprinter.Extras diff --git a/plutus-script-utils/src/Plutus/Script/Utils/ShowBS.hs b/plutus-script-utils/src/Plutus/Script/Utils/ShowBS.hs new file mode 100644 index 0000000..6bb9945 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/ShowBS.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +-- | This module exposes on-chain pretty-printing to 'BuiltinString' of the +-- types that are common to every version of the 'ScriptContext'. This is useful +-- for debugging of validators. You probably do not want to use this in +-- production code, as many of the functions in this module are wildly +-- inefficient due to limitations of the 'BuiltinString' type. +-- +-- The version-specific instances (for the 'ScriptContext' of each Plutus +-- language version) live in the @Plutus.Script.Utils.VX.ShowBS@ modules, each of +-- which re-uses the instances defined here and in the lower versions. +module Plutus.Script.Utils.ShowBS + ( ShowBS (..), + showBSParen, + application1, + application2, + application3, + application4, + catList, + integerToDigits, + digitToBS, + builtinByteStringCharacters, + showData, + ) +where + +import PlutusLedgerApi.V1 qualified as V1 +import PlutusTx.AssocMap qualified as Map +import PlutusTx.Builtins +import PlutusTx.Prelude + +-- | Analogue of Haskell's 'Prelude.Show' class to be used in Plutus scripts. +class ShowBS a where + -- | Analogue of 'Prelude.show' + showBS :: a -> BuiltinString + +-- | Print with a surrounding parenthesis +{-# INLINEABLE showBSParen #-} +showBSParen :: BuiltinString -> BuiltinString +showBSParen s = "(" <> s <> ")" + +-- | Print an application of a constructor to an argument +{-# INLINEABLE application1 #-} +application1 :: (ShowBS a) => BuiltinString -> a -> BuiltinString +application1 bs x = showBSParen $ bs <> " " <> showBS x + +-- | Like 'application1' with two arguments +{-# INLINEABLE application2 #-} +application2 :: (ShowBS a, ShowBS b) => BuiltinString -> a -> b -> BuiltinString +application2 bs x y = showBSParen $ bs <> " " <> showBS x <> " " <> showBS y + +-- | Like 'application1' with three arguments +{-# INLINEABLE application3 #-} +application3 :: (ShowBS a, ShowBS b, ShowBS c) => BuiltinString -> a -> b -> c -> BuiltinString +application3 bs x y z = showBSParen $ bs <> " " <> showBS x <> " " <> showBS y <> " " <> showBS z + +-- | Like 'application1' with four arguments +{-# INLINEABLE application4 #-} +application4 :: (ShowBS a, ShowBS b, ShowBS c, ShowBS d) => BuiltinString -> a -> b -> c -> d -> BuiltinString +application4 bs x y z w = + showBSParen $ bs <> " " <> showBS x <> " " <> showBS y <> " " <> showBS z <> " " <> showBS w + +instance ShowBS Integer where + {-# INLINEABLE showBS #-} + showBS i = mconcat (integerToDigits i) + +{-# INLINEABLE integerToDigits #-} +integerToDigits :: Integer -> [BuiltinString] +integerToDigits n + | n < 0 = "-" : go (negate n) [] + | n == 0 = ["0"] + | otherwise = go n [] + where + go i acc + | i == 0 = acc + | otherwise = let (q, r) = quotRem i 10 in go q (digitToBS r : acc) + +{-# INLINEABLE digitToBS #-} +digitToBS :: Integer -> BuiltinString +digitToBS x + | x == 0 = "0" + | x == 1 = "1" + | x == 2 = "2" + | x == 3 = "3" + | x == 4 = "4" + | x == 5 = "5" + | x == 6 = "6" + | x == 7 = "7" + | x == 8 = "8" + | x == 9 = "9" + | otherwise = "?" + +instance (ShowBS a) => ShowBS [a] where + {-# INLINEABLE showBS #-} + showBS = catList "[" "," "]" showBS + +{-# INLINEABLE catList #-} +catList :: BuiltinString -> BuiltinString -> BuiltinString -> (a -> BuiltinString) -> [a] -> BuiltinString +catList open _ close _ [] = open <> close +catList open sep close print (x : xs) = open <> print x <> printSeparated xs <> close + where + printSeparated [] = "" + printSeparated (y : ys) = sep <> print y <> printSeparated ys + +instance (ShowBS a, ShowBS b) => ShowBS (a, b) where + {-# INLINEABLE showBS #-} + showBS (x, y) = "(" <> showBS x <> "," <> showBS y <> ")" + +instance ShowBS Bool where + {-# INLINEABLE showBS #-} + showBS True = "True" + showBS False = "False" + +instance (ShowBS a) => ShowBS (Maybe a) where + {-# INLINEABLE showBS #-} + showBS Nothing = "Nothing" + showBS (Just x) = application1 "Just" x + +instance (ShowBS k, ShowBS v) => ShowBS (Map.Map k v) where + {-# INLINEABLE showBS #-} + showBS m = application1 "fromList" (Map.toList m) + +instance ShowBS BuiltinByteString where + -- base16 representation + {-# INLINEABLE showBS #-} + showBS bs = "\"" <> mconcat (builtinByteStringCharacters bs) <> "\"" + +{-# INLINEABLE builtinByteStringCharacters #-} +builtinByteStringCharacters :: BuiltinByteString -> [BuiltinString] +builtinByteStringCharacters s = go (len - 1) [] + where + len = lengthOfByteString s + + go :: Integer -> [BuiltinString] -> [BuiltinString] + go i acc + | i >= 0 = + let (highNibble, lowNibble) = quotRem (indexByteString s i) 16 + in go (i - 1) (toHex highNibble : toHex lowNibble : acc) + | otherwise = acc + + toHex :: Integer -> BuiltinString + toHex x + | x <= 9 = digitToBS x + | x == 10 = "a" + | x == 11 = "b" + | x == 12 = "c" + | x == 13 = "d" + | x == 14 = "e" + | x == 15 = "f" + | otherwise = "?" + +instance ShowBS BuiltinData where + {-# INLINEABLE showBS #-} + showBS d = showBSParen $ "BuiltinData " <> showData d + +{-# INLINEABLE showData #-} +showData :: BuiltinData -> BuiltinString +showData d = + matchData + d + (\i ds -> showBSParen $ "Constr " <> showBS i <> " " <> catList "[" "," "]" showData ds) + (\alist -> showBSParen $ "Map " <> catList "[" "," "]" (\(a, b) -> "(" <> showData a <> "," <> showData b <> ")") alist) + (\list -> showBSParen $ "List " <> catList "[" "," "]" showData list) + (\i -> showBSParen $ "I " <> showBS i) + (\bs -> showBSParen $ "B " <> showBS bs) + +instance ShowBS V1.TokenName where + {-# INLINEABLE showBS #-} + showBS (V1.TokenName x) = application1 "TokenName" x + +instance ShowBS V1.CurrencySymbol where + {-# INLINEABLE showBS #-} + showBS (V1.CurrencySymbol x) = application1 "CurrencySymbol" x + +instance ShowBS V1.Value where + {-# INLINEABLE showBS #-} + showBS (V1.Value m) = application1 "Value" m + +instance ShowBS V1.Lovelace where + {-# INLINEABLE showBS #-} + showBS (V1.Lovelace amount) = application1 "Lovelace" amount + +instance ShowBS V1.PubKeyHash where + {-# INLINEABLE showBS #-} + showBS (V1.PubKeyHash h) = application1 "PubKeyHash" h + +instance ShowBS V1.ScriptHash where + {-# INLINEABLE showBS #-} + showBS (V1.ScriptHash h) = application1 "ScriptHash" h + +instance ShowBS V1.Credential where + {-# INLINEABLE showBS #-} + showBS (V1.ScriptCredential hash) = application1 "ScriptCredential" hash + showBS (V1.PubKeyCredential pkh) = application1 "PubKeyCredential" pkh + +instance ShowBS V1.StakingCredential where + {-# INLINEABLE showBS #-} + showBS (V1.StakingHash cred) = application1 "StakingCredential" cred + showBS (V1.StakingPtr i j k) = application3 "StakingPointer" i j k + +instance ShowBS V1.DatumHash where + {-# INLINEABLE showBS #-} + showBS (V1.DatumHash h) = application1 "DatumHash" h + +instance ShowBS V1.Datum where + {-# INLINEABLE showBS #-} + showBS (V1.Datum d) = application1 "Datum" d + +instance ShowBS V1.Redeemer where + {-# INLINEABLE showBS #-} + showBS (V1.Redeemer builtinData) = application1 "Redeemer" builtinData + +instance ShowBS V1.POSIXTime where + {-# INLINEABLE showBS #-} + showBS (V1.POSIXTime t) = application1 "POSIXTime" t + +instance (ShowBS a) => ShowBS (V1.Extended a) where + {-# INLINEABLE showBS #-} + showBS V1.NegInf = "NegInf" + showBS V1.PosInf = "PosInf" + showBS (V1.Finite x) = application1 "Finite" x + +instance (ShowBS a) => ShowBS (V1.LowerBound a) where + {-# INLINEABLE showBS #-} + showBS (V1.LowerBound x closure) = application2 "LowerBound" x closure + +instance (ShowBS a) => ShowBS (V1.UpperBound a) where + {-# INLINEABLE showBS #-} + showBS (V1.UpperBound x closure) = application2 "UpperBound" x closure + +instance (ShowBS a) => ShowBS (V1.Interval a) where + {-# INLINEABLE showBS #-} + showBS (V1.Interval lb ub) = application2 "Interval" lb ub diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V1/ShowBS.hs b/plutus-script-utils/src/Plutus/Script/Utils/V1/ShowBS.hs new file mode 100644 index 0000000..83d9ecf --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V1/ShowBS.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +-- | On-chain pretty-printing to 'BuiltinString' of the types reachable from the +-- Plutus V1 'ScriptContext'. The instances for the types shared with every other +-- version live in "Plutus.Script.Utils.ShowBS", which this module re-exports the +-- instances of. +module Plutus.Script.Utils.V1.ShowBS () where + +import Plutus.Script.Utils.ShowBS +import PlutusLedgerApi.V1 qualified as V1 +import PlutusTx.Prelude + +instance ShowBS V1.Address where + {-# INLINEABLE showBS #-} + showBS (V1.Address cred mStCred) = application2 "Address" cred mStCred + +instance ShowBS V1.TxId where + {-# INLINEABLE showBS #-} + showBS (V1.TxId x) = application1 "TxId" x + +instance ShowBS V1.TxOutRef where + {-# INLINEABLE showBS #-} + showBS (V1.TxOutRef txid i) = application2 "TxOutRef" txid i + +instance ShowBS V1.TxOut where + {-# INLINEABLE showBS #-} + showBS (V1.TxOut address value mDatumHash) = application3 "TxOut" address value mDatumHash + +instance ShowBS V1.TxInInfo where + {-# INLINEABLE showBS #-} + showBS (V1.TxInInfo oref out) = application2 "TxInInfo" oref out + +instance ShowBS V1.DCert where + {-# INLINEABLE showBS #-} + showBS (V1.DCertDelegRegKey stCred) = application1 "DCertDelegRegKey" stCred + showBS (V1.DCertDelegDeRegKey stCred) = application1 "DCertDelegDeRegKey" stCred + showBS (V1.DCertDelegDelegate stCred pkh) = application2 "DCertDelegDelegate" stCred pkh + showBS (V1.DCertPoolRegister poolId poolVFR) = application2 "DCertPoolRegister" poolId poolVFR + showBS (V1.DCertPoolRetire pkh epoch) = application2 "DCertPoolRetire" pkh epoch + showBS V1.DCertGenesis = "DCertGenesis" + showBS V1.DCertMir = "DCertMir" + +instance ShowBS V1.ScriptPurpose where + {-# INLINEABLE showBS #-} + showBS (V1.Minting cs) = application1 "Minting" cs + showBS (V1.Spending oref) = application1 "Spending" oref + showBS (V1.Rewarding stCred) = application1 "Rewarding" stCred + showBS (V1.Certifying dcert) = application1 "Certifying" dcert + +instance ShowBS V1.TxInfo where + {-# INLINEABLE showBS #-} + showBS V1.TxInfo {..} = + showBSParen + $ "inputs:" + <> showBS txInfoInputs + <> "outputs:" + <> showBS txInfoOutputs + <> "fees:" + <> showBS txInfoFee + <> "minted value:" + <> showBS txInfoMint + <> "certificates:" + <> showBS txInfoDCert + <> "wdrl:" + <> showBS txInfoWdrl + <> "valid range:" + <> showBS txInfoValidRange + <> "signatories:" + <> showBS txInfoSignatories + <> "datums:" + <> showBS txInfoData + <> "transaction id:" + <> showBS txInfoId + +instance ShowBS V1.ScriptContext where + {-# INLINEABLE showBS #-} + showBS V1.ScriptContext {..} = + showBSParen + $ "Script context:" + <> "Script Tx info:" + <> showBS scriptContextTxInfo + <> "Script purpose:" + <> showBS scriptContextPurpose diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V2/ShowBS.hs b/plutus-script-utils/src/Plutus/Script/Utils/V2/ShowBS.hs new file mode 100644 index 0000000..dfcd4eb --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V2/ShowBS.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +-- | On-chain pretty-printing to 'BuiltinString' of the types that are +-- introduced by the Plutus V2 'ScriptContext'. The types shared with V1 (and +-- with every version) are handled by "Plutus.Script.Utils.V1.ShowBS" and +-- "Plutus.Script.Utils.ShowBS", whose instances this module re-exports. +module Plutus.Script.Utils.V2.ShowBS () where + +import Plutus.Script.Utils.ShowBS +import Plutus.Script.Utils.V1.ShowBS () +import PlutusLedgerApi.V2 qualified as V2 +import PlutusTx.Prelude + +instance ShowBS V2.OutputDatum where + {-# INLINEABLE showBS #-} + showBS V2.NoOutputDatum = "NoOutputDatum" + showBS (V2.OutputDatumHash h) = application1 "OutputDatumHash" h + showBS (V2.OutputDatum d) = application1 "OutputDatum" d + +instance ShowBS V2.TxOut where + {-# INLINEABLE showBS #-} + showBS (V2.TxOut address value datum mRefScriptHash) = application4 "TxOut" address value datum mRefScriptHash + +instance ShowBS V2.TxInInfo where + {-# INLINEABLE showBS #-} + showBS (V2.TxInInfo oref out) = application2 "TxInInfo" oref out + +instance ShowBS V2.TxInfo where + {-# INLINEABLE showBS #-} + showBS V2.TxInfo {..} = + showBSParen + $ "inputs:" + <> showBS txInfoInputs + <> "reference inputs:" + <> showBS txInfoReferenceInputs + <> "outputs:" + <> showBS txInfoOutputs + <> "fees:" + <> showBS txInfoFee + <> "minted value:" + <> showBS txInfoMint + <> "certificates:" + <> showBS txInfoDCert + <> "wdrl:" + <> showBS txInfoWdrl + <> "valid range:" + <> showBS txInfoValidRange + <> "signatories:" + <> showBS txInfoSignatories + <> "redeemers:" + <> showBS txInfoRedeemers + <> "datums:" + <> showBS txInfoData + <> "transaction id:" + <> showBS txInfoId + +instance ShowBS V2.ScriptContext where + {-# INLINEABLE showBS #-} + showBS V2.ScriptContext {..} = + showBSParen + $ "Script context:" + <> "Script Tx info:" + <> showBS scriptContextTxInfo + <> "Script purpose:" + <> showBS scriptContextPurpose diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V3/ShowBS.hs b/plutus-script-utils/src/Plutus/Script/Utils/V3/ShowBS.hs new file mode 100644 index 0000000..5193818 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V3/ShowBS.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +-- | On-chain pretty-printing to 'BuiltinString' of the types that are +-- introduced by the Plutus V3 'ScriptContext' (in particular the governance +-- types of the Conway era). The types shared with the lower versions are +-- handled by "Plutus.Script.Utils.V2.ShowBS" and the modules it re-exports, all +-- of whose instances this module re-exports. +module Plutus.Script.Utils.V3.ShowBS () where + +import Plutus.Script.Utils.ShowBS +import Plutus.Script.Utils.V2.ShowBS () +import PlutusLedgerApi.V3 qualified as V3 +import PlutusTx.Prelude +import PlutusTx.Ratio qualified as Ratio + +instance ShowBS Ratio.Rational where + {-# INLINEABLE showBS #-} + showBS rat = application2 "Rational" (Ratio.numerator rat) (Ratio.denominator rat) + +instance ShowBS V3.MintValue where + {-# INLINEABLE showBS #-} + showBS mVal = showBS $ V3.mintValueMinted mVal <> negate (V3.mintValueBurned mVal) + +instance ShowBS V3.TxId where + {-# INLINEABLE showBS #-} + showBS (V3.TxId x) = application1 "TxId" x + +instance ShowBS V3.TxOutRef where + {-# INLINEABLE showBS #-} + showBS (V3.TxOutRef txid i) = application2 "TxOutRef" txid i + +instance ShowBS V3.TxInInfo where + {-# INLINEABLE showBS #-} + showBS (V3.TxInInfo oref out) = application2 "TxInInfo" oref out + +instance ShowBS V3.DRepCredential where + {-# INLINEABLE showBS #-} + showBS (V3.DRepCredential cred) = application1 "DRep credential" cred + +instance ShowBS V3.DRep where + {-# INLINEABLE showBS #-} + showBS (V3.DRep dRepCred) = application1 "DRep" dRepCred + showBS V3.DRepAlwaysAbstain = "DRep always abstain" + showBS V3.DRepAlwaysNoConfidence = "DRep always no confidence" + +instance ShowBS V3.Delegatee where + {-# INLINEABLE showBS #-} + showBS (V3.DelegStake pkh) = application1 "Delegate stake" pkh + showBS (V3.DelegVote dRep) = application1 "Delegate vote" dRep + showBS (V3.DelegStakeVote pkh dRep) = application2 "Delegate stake vote" pkh dRep + +instance ShowBS V3.TxCert where + {-# INLINEABLE showBS #-} + showBS (V3.TxCertRegStaking cred maybeDepositAmount) = application2 "Register staking" cred maybeDepositAmount + showBS (V3.TxCertUnRegStaking cred maybeDepositAmount) = application2 "Unregister staking" cred maybeDepositAmount + showBS (V3.TxCertDelegStaking cred delegatee) = application2 "Delegate staking" cred delegatee + showBS (V3.TxCertRegDeleg cred delegatee depositAmount) = application3 "Register and delegate staking" cred delegatee depositAmount + showBS (V3.TxCertRegDRep dRepCred amount) = application2 "Register DRep" dRepCred amount + showBS (V3.TxCertUpdateDRep dRepCred) = application1 "Update DRep" dRepCred + showBS (V3.TxCertUnRegDRep dRepCred amount) = application2 "Unregister DRep" dRepCred amount + showBS (V3.TxCertPoolRegister poolId poolVFR) = application2 "Register to pool" poolId poolVFR + showBS (V3.TxCertPoolRetire pkh epoch) = application2 "Retire from pool" pkh epoch + showBS (V3.TxCertAuthHotCommittee coldCommitteeCred hotCommitteeCred) = application2 "Authorize hot committee" coldCommitteeCred hotCommitteeCred + showBS (V3.TxCertResignColdCommittee coldCommitteeCred) = application1 "Resign cold committee" coldCommitteeCred + +instance ShowBS V3.Voter where + {-# INLINEABLE showBS #-} + showBS (V3.CommitteeVoter hotCommitteeCred) = application1 "Committee Voter" hotCommitteeCred + showBS (V3.DRepVoter dRepCred) = application1 "DRep Voter" dRepCred + showBS (V3.StakePoolVoter pkh) = application1 "Stake Pool Voter" pkh + +instance ShowBS V3.Vote where + {-# INLINEABLE showBS #-} + showBS V3.VoteNo = "No" + showBS V3.VoteYes = "Yes" + showBS V3.Abstain = "Abstain" + +instance ShowBS V3.ChangedParameters where + {-# INLINEABLE showBS #-} + showBS (V3.ChangedParameters builtinData) = application1 "Changed parameters" builtinData + +instance ShowBS V3.ColdCommitteeCredential where + {-# INLINEABLE showBS #-} + showBS (V3.ColdCommitteeCredential cred) = application1 "Cold committee credential" cred + +instance ShowBS V3.HotCommitteeCredential where + {-# INLINEABLE showBS #-} + showBS (V3.HotCommitteeCredential cred) = application1 "Hot committee credential" cred + +instance ShowBS V3.GovernanceActionId where + {-# INLINEABLE showBS #-} + showBS (V3.GovernanceActionId txid ix) = application2 "GovernanceActionId" txid ix + +instance ShowBS V3.ProtocolVersion where + {-# INLINEABLE showBS #-} + showBS (V3.ProtocolVersion major minor) = application2 "Protocol version" major minor + +instance ShowBS V3.Constitution where + {-# INLINEABLE showBS #-} + showBS (V3.Constitution constitutionScript) = application1 "Constitution" constitutionScript + +instance ShowBS V3.Committee where + {-# INLINEABLE showBS #-} + showBS (V3.Committee committeeMembers committeeQuorum) = application2 "Committee" committeeMembers committeeQuorum + +instance ShowBS V3.GovernanceAction where + {-# INLINEABLE showBS #-} + showBS (V3.ParameterChange maybeActionId changeParams mScriptHash) = application3 "Parameter change" maybeActionId changeParams mScriptHash + showBS (V3.HardForkInitiation maybeActionId protocolVersion) = application2 "HardForkInitiation" maybeActionId protocolVersion + showBS (V3.TreasuryWithdrawals mapCredLovelace mScriptHash) = application2 "TreasuryWithdrawals" mapCredLovelace mScriptHash + showBS (V3.NoConfidence maybeActionId) = application1 "NoConfidence" maybeActionId + showBS (V3.UpdateCommittee maybeActionId toRemoveCreds toAddCreds quorum) = application4 "UpdateCommittee" maybeActionId toRemoveCreds toAddCreds quorum + showBS (V3.NewConstitution maybeActionId constitution) = application2 "NewConstitution" maybeActionId constitution + showBS V3.InfoAction = "InfoAction" + +instance ShowBS V3.ProposalProcedure where + {-# INLINEABLE showBS #-} + showBS (V3.ProposalProcedure ppDeposit ppReturnAddr ppGovernanceAction) = application3 "ProposalProcedure" ppDeposit ppReturnAddr ppGovernanceAction + +instance ShowBS V3.ScriptPurpose where + {-# INLINEABLE showBS #-} + showBS (V3.Minting cs) = application1 "Minting" cs + showBS (V3.Spending oref) = application1 "Spending" oref + showBS (V3.Rewarding cred) = application1 "Rewarding" cred + showBS (V3.Certifying nb txCert) = application2 "Certifying" nb txCert + showBS (V3.Voting voter) = application1 "Voting" voter + showBS (V3.Proposing nb proposal) = application2 "Proposing" nb proposal + +instance ShowBS V3.ScriptInfo where + {-# INLINEABLE showBS #-} + showBS (V3.MintingScript cs) = application1 "MintingScript" cs + showBS (V3.SpendingScript oref mDat) = application2 "SpendingScript" oref mDat + showBS (V3.RewardingScript cred) = application1 "RewardingScript" cred + showBS (V3.CertifyingScript nb txCert) = application2 "CertifyingScript" nb txCert + showBS (V3.VotingScript voter) = application1 "VotingScript" voter + showBS (V3.ProposingScript nb proposal) = application2 "ProposingScript" nb proposal + +instance ShowBS V3.TxInfo where + {-# INLINEABLE showBS #-} + showBS V3.TxInfo {..} = + showBSParen + $ "inputs:" + <> showBS txInfoInputs + <> "reference inputs:" + <> showBS txInfoReferenceInputs + <> "outputs:" + <> showBS txInfoOutputs + <> "fees:" + <> showBS txInfoFee + <> "minted value:" + <> showBS txInfoMint + <> "certificates:" + <> showBS txInfoTxCerts + <> "wdrl:" + <> showBS txInfoWdrl + <> "valid range:" + <> showBS txInfoValidRange + <> "signatories:" + <> showBS txInfoSignatories + <> "redeemers:" + <> showBS txInfoRedeemers + <> "datums:" + <> showBS txInfoData + <> "transaction id:" + <> showBS txInfoId + <> "votes:" + <> showBS txInfoVotes + <> "proposals:" + <> showBS txInfoProposalProcedures + <> "treasury amount:" + <> showBS txInfoCurrentTreasuryAmount + <> "treasury donation:" + <> showBS txInfoTreasuryDonation + +instance ShowBS V3.ScriptContext where + {-# INLINEABLE showBS #-} + showBS V3.ScriptContext {..} = + showBSParen + $ "Script context:" + <> "Script Tx info:" + <> showBS scriptContextTxInfo + <> "Script redeemer:" + <> showBS scriptContextRedeemer + <> "Script info:" + <> showBS scriptContextScriptInfo diff --git a/plutus-script-utils/src/Plutus/Script/Utils/V4/ShowBS.hs b/plutus-script-utils/src/Plutus/Script/Utils/V4/ShowBS.hs new file mode 100644 index 0000000..810e595 --- /dev/null +++ b/plutus-script-utils/src/Plutus/Script/Utils/V4/ShowBS.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} + +-- | On-chain pretty-printing to 'BuiltinString' of the types that are +-- introduced or redefined by the Plutus V4 'ScriptContext' (accounts, guards and +-- the nested top-level transaction view). The types shared with the lower +-- versions are handled by "Plutus.Script.Utils.V3.ShowBS" and the modules it +-- re-exports, all of whose instances this module re-exports. +module Plutus.Script.Utils.V4.ShowBS () where + +import Plutus.Script.Utils.ShowBS +import Plutus.Script.Utils.V3.ShowBS () +import PlutusLedgerApi.V4 qualified as V4 +import PlutusTx.Prelude + +instance ShowBS V4.AccountId where + {-# INLINEABLE showBS #-} + showBS (V4.AccountId cred) = application1 "AccountId" cred + +instance ShowBS V4.Address where + {-# INLINEABLE showBS #-} + showBS (V4.Address cred mAccountId) = application2 "Address" cred mAccountId + +instance ShowBS V4.TxOutRef where + {-# INLINEABLE showBS #-} + showBS oref = application2 "TxOutRef" (V4.txOutRefId oref) (V4.txOutRefIdx oref) + +instance ShowBS V4.TxOut where + {-# INLINEABLE showBS #-} + showBS (V4.TxOut address value datum mRefScriptHash) = application4 "TxOut" address value datum mRefScriptHash + +instance ShowBS V4.Rational where + {-# INLINEABLE showBS #-} + showBS rat = application2 "Rational" (V4.numerator rat) (V4.denominator rat) + +instance ShowBS V4.POSIXTimeRange where + {-# INLINEABLE showBS #-} + showBS (V4.POSIXTimeRange lo hi) = application2 "POSIXTimeRange" lo hi + +instance ShowBS V4.AccountBalanceInterval where + {-# INLINEABLE showBS #-} + showBS (V4.AccountBalanceLowerBound lo) = application1 "AccountBalanceLowerBound" lo + showBS (V4.AccountBalanceUpperBound hi) = application1 "AccountBalanceUpperBound" hi + showBS (V4.AccountBalanceBothBounds lo hi) = application2 "AccountBalanceBothBounds" lo hi + showBS (V4.AccountBalanceExact amount) = application1 "AccountBalanceExact" amount + +instance ShowBS V4.AccountBalanceIntervals where + {-# INLINEABLE showBS #-} + showBS (V4.AccountBalanceIntervals m) = application1 "AccountBalanceIntervals" m + +instance ShowBS V4.GovernanceActionId where + {-# INLINEABLE showBS #-} + showBS gaid = application2 "GovernanceActionId" (V4.gaidTxId gaid) (V4.gaidGovActionIx gaid) + +instance ShowBS V4.ProtocolVersion where + {-# INLINEABLE showBS #-} + showBS pv = application2 "Protocol version" (V4.pvMajor pv) (V4.pvMinor pv) + +instance ShowBS V4.Constitution where + {-# INLINEABLE showBS #-} + showBS (V4.Constitution constitutionScript) = application1 "Constitution" constitutionScript + +instance ShowBS V4.Committee where + {-# INLINEABLE showBS #-} + showBS committee = application2 "Committee" (V4.committeeMembers committee) (V4.committeeQuorum committee) + +instance ShowBS V4.GovernanceAction where + {-# INLINEABLE showBS #-} + showBS (V4.ParameterChange maybeActionId changeParams mScriptHash) = application3 "Parameter change" maybeActionId changeParams mScriptHash + showBS (V4.HardForkInitiation maybeActionId protocolVersion) = application2 "HardForkInitiation" maybeActionId protocolVersion + showBS (V4.TreasuryWithdrawals mapCredLovelace mScriptHash) = application2 "TreasuryWithdrawals" mapCredLovelace mScriptHash + showBS (V4.NoConfidence maybeActionId) = application1 "NoConfidence" maybeActionId + showBS (V4.UpdateCommittee maybeActionId toRemoveCreds toAddCreds quorum) = application4 "UpdateCommittee" maybeActionId toRemoveCreds toAddCreds quorum + showBS (V4.NewConstitution maybeActionId constitution) = application2 "NewConstitution" maybeActionId constitution + showBS V4.InfoAction = "InfoAction" + +instance ShowBS V4.ProposalProcedure where + {-# INLINEABLE showBS #-} + showBS pp = application3 "ProposalProcedure" (V4.ppDeposit pp) (V4.ppReturnAddr pp) (V4.ppGovernanceAction pp) + +instance ShowBS V4.TxCert where + {-# INLINEABLE showBS #-} + showBS (V4.TxCertRegAccount accountId depositAmount) = application2 "Register account" accountId depositAmount + showBS (V4.TxCertUnRegAccount accountId refundAmount) = application2 "Unregister account" accountId refundAmount + showBS (V4.TxCertDelegAccount accountId delegatee) = application2 "Delegate account" accountId delegatee + showBS (V4.TxCertRegAccountDeleg accountId delegatee depositAmount) = application3 "Register and delegate account" accountId delegatee depositAmount + showBS (V4.TxCertRegDRep dRepCred amount) = application2 "Register DRep" dRepCred amount + showBS (V4.TxCertUpdateDRep dRepCred) = application1 "Update DRep" dRepCred + showBS (V4.TxCertUnRegDRep dRepCred amount) = application2 "Unregister DRep" dRepCred amount + showBS (V4.TxCertPoolRegister poolId poolVFR) = application2 "Register to pool" poolId poolVFR + showBS (V4.TxCertPoolRetire pkh epoch) = application2 "Retire from pool" pkh epoch + showBS (V4.TxCertAuthHotCommittee coldCommitteeCred hotCommitteeCred) = application2 "Authorize hot committee" coldCommitteeCred hotCommitteeCred + showBS (V4.TxCertResignColdCommittee coldCommitteeCred) = application1 "Resign cold committee" coldCommitteeCred + +instance ShowBS V4.ScriptPurpose where + {-# INLINEABLE showBS #-} + showBS (V4.Minting scriptHash cs) = application2 "Minting" scriptHash cs + showBS (V4.Spending scriptHash oref) = application2 "Spending" scriptHash oref + showBS (V4.Withdrawing scriptHash cred) = application2 "Withdrawing" scriptHash cred + showBS (V4.Certifying scriptHash nb txCert) = application3 "Certifying" scriptHash nb txCert + showBS (V4.Voting scriptHash voter) = application2 "Voting" scriptHash voter + showBS (V4.Proposing scriptHash nb proposal) = application3 "Proposing" scriptHash nb proposal + showBS (V4.Guarding scriptHash nb) = application2 "Guarding" scriptHash nb + +instance ShowBS V4.ScriptInfo where + {-# INLINEABLE showBS #-} + showBS (V4.MintingScript cs) = application1 "MintingScript" cs + showBS (V4.SpendingScript oref mDat) = application2 "SpendingScript" oref mDat + showBS (V4.WithdrawingScript accountId) = application1 "WithdrawingScript" accountId + showBS (V4.CertifyingScript nb txCert) = application2 "CertifyingScript" nb txCert + showBS (V4.VotingScript voter) = application1 "VotingScript" voter + showBS (V4.ProposingScript nb proposal) = application2 "ProposingScript" nb proposal + showBS (V4.GuardingScript nb mTopTxInfo) = application2 "GuardingScript" nb mTopTxInfo + +instance ShowBS V4.TxInInfo where + {-# INLINEABLE showBS #-} + showBS (V4.TxInInfo oref out) = application2 "TxInInfo" oref out + +instance ShowBS V4.TxInfo where + {-# INLINEABLE showBS #-} + showBS V4.TxInfo {..} = + showBSParen + $ "transaction id:" + <> showBS txInfoId + <> "sub-transaction index:" + <> showBS txInfoSubTxIx + <> "inputs:" + <> showBS txInfoInputs + <> "reference inputs:" + <> showBS txInfoReferenceInputs + <> "outputs:" + <> showBS txInfoOutputs + <> "minted value:" + <> showBS txInfoMint + <> "certificates:" + <> showBS txInfoTxCerts + <> "withdrawals:" + <> showBS txInfoWithdrawals + <> "direct deposits:" + <> showBS txInfoDirectDeposits + <> "account balance intervals:" + <> showBS txInfoAccountBalanceIntervals + <> "valid range:" + <> showBS txInfoValidRange + <> "guards:" + <> showBS txInfoGuards + <> "required top-level guards:" + <> showBS txInfoRequiredTopLevelGuards + <> "redeemers:" + <> showBS txInfoRedeemers + <> "datums:" + <> showBS txInfoData + <> "votes:" + <> showBS txInfoVotes + <> "proposals:" + <> showBS txInfoProposalProcedures + <> "treasury amount:" + <> showBS txInfoCurrentTreasuryAmount + <> "treasury donation:" + <> showBS txInfoTreasuryDonation + +instance ShowBS V4.TopTxInfoSimplified where + {-# INLINEABLE showBS #-} + showBS V4.TopTxInfoSimplified {..} = + showBSParen + $ "transaction ids:" + <> showBS ttisIds + <> "inputs:" + <> showBS ttisInputs + <> "reference inputs:" + <> showBS ttisReferenceInputs + <> "outputs:" + <> showBS ttisOutputs + <> "mints:" + <> showBS ttisMints + <> "burns:" + <> showBS ttisBurns + <> "certificates:" + <> showBS ttisTxCerts + <> "withdrawals:" + <> showBS ttisWithdrawals + <> "direct deposits:" + <> showBS ttisDirectDeposits + <> "valid range:" + <> showBS ttisValidRange + <> "guards:" + <> showBS ttisGuards + <> "required top-level guards:" + <> showBS ttisRequiredTopLevelGuards + <> "script purposes:" + <> showBS ttisScriptPurposes + <> "datums:" + <> showBS ttisData + <> "votes:" + <> showBS ttisVotes + <> "proposals:" + <> showBS ttisProposalProcedures + <> "treasury amount:" + <> showBS ttisCurrentTreasuryAmount + <> "treasury donations:" + <> showBS ttisTreasuryDonations + +instance ShowBS V4.TopTxInfo where + {-# INLINEABLE showBS #-} + showBS V4.TopTxInfo {..} = + showBSParen + $ "sub-transactions:" + <> showBS topTxInfoSubTransactions + <> "datums:" + <> showBS topTxInfoDatums + <> "starting account balance intervals:" + <> showBS topTxInfoStartingAccountBalanceIntervals + <> "simplified:" + <> showBS topTxInfoSimplified + +instance ShowBS V4.ScriptContext where + {-# INLINEABLE showBS #-} + showBS V4.ScriptContext {..} = + showBSParen + $ "Script context:" + <> "Script Tx info:" + <> showBS scriptContextTxInfo + <> "Script redeemer:" + <> showBS scriptContextRedeemer + <> "Script info:" + <> showBS scriptContextScriptInfo + <> "Script hash:" + <> showBS scriptContextScriptHash From 05d4058ac0d8b6f8e0161da315b9903bf32899bf Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 14:29:45 +0200 Subject: [PATCH 6/8] Add cabal.project.hls for HLS PlutusTx plugin support Referenced by hie.yaml; layers editor-only GHC options (-fwrite-if-simplified-core, -fprefer-byte-code) on cabal.project. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- cabal.project.hls | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 cabal.project.hls diff --git a/cabal.project.hls b/cabal.project.hls new file mode 100644 index 0000000..590c50d --- /dev/null +++ b/cabal.project.hls @@ -0,0 +1,31 @@ +-- Project file used only by HLS/hie-bios (see hie.yaml), not by regular +-- `cabal build`. It layers editor-only GHC options on top of the normal +-- cabal.project. +-- +-- Why this exists: the PlutusTx plugin compiles quoted `$$(compile [|| .. ||])` +-- terms and needs the GHC Core unfoldings of referenced INLINABLE bindings. +-- A normal `cabal build` gets these via `-fobject-code` plus the interface +-- pragma flags set in each package. HLS, however, loads modules with the +-- bytecode interpreter, where those unfoldings are absent, so the plugin fails +-- and (because of `-fplugin-opt PlutusTx.Plugin:defer-errors`) surfaces the +-- failures as editor-only diagnostics. +-- +-- The fix (GHC 9.6+) is to have GHC persist the simplified Core into the +-- interface files and let the bytecode session restore it, which is exactly +-- what `-fwrite-if-simplified-core` + `-fprefer-byte-code` do. +-- Scope the options to our own packages only. HLS compiles just our source; +-- dependencies are loaded from their prebuilt artifacts, so a `package *` +-- stanza here would needlessly force a rebuild of the whole dependency tree on +-- first HLS load. +import: cabal.project + +package plutus-ledger + ghc-options: -fwrite-if-simplified-core -fprefer-byte-code +package plutus-script-utils + ghc-options: -fwrite-if-simplified-core -fprefer-byte-code +package cardano-node-emulator + ghc-options: -fwrite-if-simplified-core -fprefer-byte-code +package cardano-node-socket-emulator + ghc-options: -fwrite-if-simplified-core -fprefer-byte-code +package freer-extras + ghc-options: -fwrite-if-simplified-core -fprefer-byte-code From 2f5adea1557bd21057fd7b54da17afa6618f7dda Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 15:23:34 +0200 Subject: [PATCH 7/8] plutus-ledger: migrate to new deps and bump emulator era to Dijkstra Make plutus-ledger and plutus-script-utils compile against the updated cardano-api/cardano-ledger stack and bump the emulator's canonical era from Conway to Dijkstra so that PlutusV4 is supported and the incomplete-pattern warnings disappear. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- plutus-ledger/package.yaml | 7 +- plutus-ledger/plutus-ledger.cabal | 9 +- plutus-ledger/src/Ledger/Address.hs | 7 +- plutus-ledger/src/Ledger/Index.hs | 10 +- plutus-ledger/src/Ledger/Index/Internal.hs | 15 +-- plutus-ledger/src/Ledger/Orphans.hs | 4 +- plutus-ledger/src/Ledger/Test.hs | 3 +- plutus-ledger/src/Ledger/Tx.hs | 29 ++--- plutus-ledger/src/Ledger/Tx/CardanoAPI.hs | 48 ++++---- .../src/Ledger/Tx/CardanoAPI/Internal.hs | 111 ++++++++++-------- plutus-ledger/src/Ledger/Tx/Internal.hs | 23 ++-- plutus-ledger/src/Ledger/Tx/Orphans.hs | 6 +- .../test/Ledger/Tx/CardanoAPISpec.hs | 2 +- plutus-ledger/test/Spec.hs | 12 +- .../src/Plutus/Script/Utils/Address.hs | 2 +- 15 files changed, 147 insertions(+), 141 deletions(-) diff --git a/plutus-ledger/package.yaml b/plutus-ledger/package.yaml index 89d3a51..ef8982a 100644 --- a/plutus-ledger/package.yaml +++ b/plutus-ledger/package.yaml @@ -22,7 +22,6 @@ default-extensions: - ExplicitForAll - FlexibleContexts - FlexibleInstances - - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - LambdaCase @@ -31,7 +30,6 @@ default-extensions: - NamedFieldPuns - NumericUnderscores - OverloadedStrings - - PolyKinds - RankNTypes - RecordWildCards - ScopedTypeVariables @@ -78,7 +76,7 @@ library: - cardano-crypto - cardano-ledger-alonzo - cardano-ledger-byron - - cardano-ledger-conway + - cardano-ledger-dijkstra - cardano-ledger-core - cardano-ledger-shelley - containers @@ -86,8 +84,9 @@ library: - flat - hashable - http-api-data - - optics-core + - lens - memory + - newtype-generics - ordered-containers - plutus-core - plutus-ledger-api diff --git a/plutus-ledger/plutus-ledger.cabal b/plutus-ledger/plutus-ledger.cabal index c4252f8..530d9e0 100644 --- a/plutus-ledger/plutus-ledger.cabal +++ b/plutus-ledger/plutus-ledger.cabal @@ -61,7 +61,6 @@ library ExplicitForAll FlexibleContexts FlexibleInstances - GADTs GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase @@ -70,7 +69,6 @@ library NamedFieldPuns NumericUnderscores OverloadedStrings - PolyKinds RankNTypes RecordWildCards ScopedTypeVariables @@ -92,8 +90,8 @@ library , cardano-crypto , cardano-ledger-alonzo , cardano-ledger-byron - , cardano-ledger-conway , cardano-ledger-core + , cardano-ledger-dijkstra , cardano-ledger-shelley , cborg , containers @@ -101,8 +99,9 @@ library , flat , hashable , http-api-data + , lens , memory - , optics-core + , newtype-generics , ordered-containers , plutus-core , plutus-ledger-api @@ -142,7 +141,6 @@ test-suite plutus-ledger-test ExplicitForAll FlexibleContexts FlexibleInstances - GADTs GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase @@ -151,7 +149,6 @@ test-suite plutus-ledger-test NamedFieldPuns NumericUnderscores OverloadedStrings - PolyKinds RankNTypes RecordWildCards ScopedTypeVariables diff --git a/plutus-ledger/src/Ledger/Address.hs b/plutus-ledger/src/Ledger/Address.hs index 0eee6ee..3ec73d8 100644 --- a/plutus-ledger/src/Ledger/Address.hs +++ b/plutus-ledger/src/Ledger/Address.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -59,11 +58,11 @@ import PlutusTx.Lift (makeLift) import PlutusTx.Prelude qualified as PlutusTx import Prettyprinter (Pretty) -type CardanoAddress = C.AddressInEra C.ConwayEra +type CardanoAddress = C.AddressInEra C.DijkstraEra -instance ToJSONKey (C.AddressInEra C.ConwayEra) +instance ToJSONKey (C.AddressInEra C.DijkstraEra) -instance FromJSONKey (C.AddressInEra C.ConwayEra) +instance FromJSONKey (C.AddressInEra C.DijkstraEra) cardanoAddressCredential :: C.AddressInEra era -> Credential cardanoAddressCredential (C.AddressInEra C.ByronAddressInAnyEra (C.ByronAddress address)) = diff --git a/plutus-ledger/src/Ledger/Index.hs b/plutus-ledger/src/Ledger/Index.hs index 28501f1..a50f1ef 100644 --- a/plutus-ledger/src/Ledger/Index.hs +++ b/plutus-ledger/src/Ledger/Index.hs @@ -51,7 +51,7 @@ where import Cardano.Api qualified as C import Cardano.Ledger.Coin (Coin (Coin)) -import Cardano.Ledger.Conway qualified as Conway +import Cardano.Ledger.Dijkstra qualified as Dijkstra import Cardano.Ledger.Core (PParams, getMinCoinTxOut) import Cardano.Ledger.Shelley.API qualified as C.Ledger import Control.Lens (alaf, (&), (.~), (<&>)) @@ -88,7 +88,7 @@ initialise :: Blockchain -> UtxoIndex initialise = (`insertBlock` mempty) . concat -- | Create an index with a single UTxO. -singleton :: C.TxIn -> C.TxOut C.CtxUTxO C.ConwayEra -> UtxoIndex +singleton :: C.TxIn -> C.TxOut C.CtxUTxO C.DijkstraEra -> UtxoIndex singleton txIn txOut = C.UTxO $ Map.singleton txIn txOut -- | Update the index for the addition of a transaction. @@ -121,7 +121,7 @@ lookup i index = case lookupUTxO i index of Nothing -> Nothing -- | Find an unspent transaction output (using the Ledger type) by the 'TxIn' that spends it. -lookupUTxO :: C.TxIn -> UtxoIndex -> Maybe (C.TxOut C.CtxUTxO C.ConwayEra) +lookupUTxO :: C.TxIn -> UtxoIndex -> Maybe (C.TxOut C.CtxUTxO C.DijkstraEra) lookupUTxO i index = Map.lookup i $ C.unUTxO index getCollateral :: UtxoIndex -> CardanoTx -> C.Value @@ -133,7 +133,7 @@ getCollateral idx tx = case getCardanoTxTotalCollateral tx of -- | Adjust a single transaction output so it contains at least the minimum amount of Ada -- and return the adjustment (if any) and the updated TxOut. -adjustTxOut :: PParams Conway.ConwayEra -> TxOut -> ([Coin], Tx.TxOut) +adjustTxOut :: PParams Dijkstra.DijkstraEra -> TxOut -> ([Coin], Tx.TxOut) adjustTxOut params txOut = do -- Increasing the ada amount can also increase the size in bytes, so start with a rough estimated amount of ada let withMinAdaValue = toCardanoTxOutValue $ txOutValue txOut \/ lovelaceToValue (minAdaTxOut params txOut) @@ -148,7 +148,7 @@ adjustTxOut params txOut = do -- | Exact computation of the mimimum Ada required for a given TxOut. -- TODO: Should be moved to cardano-api-extended once created -minAdaTxOut :: PParams Conway.ConwayEra -> TxOut -> Coin +minAdaTxOut :: PParams Dijkstra.DijkstraEra -> TxOut -> Coin minAdaTxOut params txOut = let toLovelace = Coin . C.Ledger.unCoin initialValue = txOutValue txOut diff --git a/plutus-ledger/src/Ledger/Index/Internal.hs b/plutus-ledger/src/Ledger/Index/Internal.hs index 842d6e2..de19fdb 100644 --- a/plutus-ledger/src/Ledger/Index/Internal.hs +++ b/plutus-ledger/src/Ledger/Index/Internal.hs @@ -18,8 +18,9 @@ module Ledger.Index.Internal where import Cardano.Api qualified as C import Cardano.Binary qualified as CBOR import Cardano.Ledger.Alonzo.Scripts (AsIx, ExUnits, PlutusPurpose) -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (AlonzoTx), IsValid (IsValid)) -import Cardano.Ledger.Core (Tx) +import Cardano.Ledger.Alonzo.Tx (pattern IsValid) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (DijkstraTx), pattern MkDijkstraTx) +import Cardano.Ledger.Core (TopTx, Tx) import Cardano.Ledger.Shelley.API (Validated, extractTx) import Codec.Serialise (Serialise (..)) import Control.Lens (makePrisms) @@ -37,7 +38,7 @@ import Prelude hiding (lookup) -- | A transaction on the blockchain. -- Invalid transactions are still put on the chain to be able to collect fees. -newtype OnChainTx = OnChainTx {getOnChainTx :: Validated (Tx EmulatorEra)} +newtype OnChainTx = OnChainTx {getOnChainTx :: Validated (Tx TopTx EmulatorEra)} deriving (Eq, Show, Generic) instance Serialise OnChainTx where @@ -45,15 +46,15 @@ instance Serialise OnChainTx where decode = fail "Not allowed to use `decode` on `OnChainTx`" -- Unused eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r -eitherTx ifInvalid ifValid (extractTx . getOnChainTx -> tx@(AlonzoTx _ _ (IsValid isValid) _)) = - let ctx = CardanoEmulatorEraTx (C.ShelleyTx C.ShelleyBasedEraConway tx) +eitherTx ifInvalid ifValid (extractTx . getOnChainTx -> tx@(MkDijkstraTx (DijkstraTx _ _ (IsValid isValid) _))) = + let ctx = CardanoEmulatorEraTx (C.ShelleyTx C.ShelleyBasedEraDijkstra tx) in if isValid then ifValid ctx else ifInvalid ctx unOnChain :: OnChainTx -> CardanoTx unOnChain = eitherTx id id -- | The UTxOs of a blockchain indexed by their references. -type UtxoIndex = C.UTxO C.ConwayEra +type UtxoIndex = C.UTxO C.DijkstraEra -- | A reason why a transaction is invalid. data ValidationError @@ -82,7 +83,7 @@ deriving via (PrettyShow ValidationPhase) instance Pretty ValidationPhase type ValidationErrorInPhase = (ValidationPhase, ValidationError) -type ValidationSuccess = (RedeemerReport, Validated (Tx EmulatorEra)) +type ValidationSuccess = (RedeemerReport, Validated (Tx TopTx EmulatorEra)) type RedeemerReport = Map.Map (PlutusPurpose AsIx EmulatorEra) ([Text], ExUnits) diff --git a/plutus-ledger/src/Ledger/Orphans.hs b/plutus-ledger/src/Ledger/Orphans.hs index 2be3d3d..98dbd0e 100644 --- a/plutus-ledger/src/Ledger/Orphans.hs +++ b/plutus-ledger/src/Ledger/Orphans.hs @@ -53,14 +53,14 @@ deriving instance Data C.NetworkId deriving instance Generic C.NetworkId -instance Serialise (C.AddressInEra C.ConwayEra) where +instance Serialise (C.AddressInEra C.DijkstraEra) where encode = encode . C.serialiseToRawBytes decode = do bs <- decode either (fail . show) pure - $ C.deserialiseFromRawBytes (C.AsAddressInEra C.AsConwayEra) bs + $ C.deserialiseFromRawBytes (C.AsAddressInEra C.AsDijkstraEra) bs deriving instance Generic C.PolicyId diff --git a/plutus-ledger/src/Ledger/Test.hs b/plutus-ledger/src/Ledger/Test.hs index 6787eac..c55ff59 100644 --- a/plutus-ledger/src/Ledger/Test.hs +++ b/plutus-ledger/src/Ledger/Test.hs @@ -12,7 +12,7 @@ import Ledger.Address qualified as Ledger import Ledger.Value.CardanoAPI (policyId) import Plutus.Script.Utils.Address (ToCardanoAddress (toCardanoAddress)) import Plutus.Script.Utils.Scripts - ( Language (PlutusV1, PlutusV2, PlutusV3), + ( Language (PlutusV1, PlutusV2, PlutusV3, PlutusV4), MintingPolicy, MintingPolicyHash, Validator, @@ -84,6 +84,7 @@ coinMintingPolicy lang = case lang of PlutusV1 -> Versioned coinMintingPolicyV1 lang PlutusV2 -> Versioned coinMintingPolicyV2 lang PlutusV3 -> error "Unsupported" + PlutusV4 -> error "Unsupported" coinMintingPolicyV1 :: MintingPolicy coinMintingPolicyV1 = toMintingPolicy $$(PlutusTx.compile [||V1.mkUntypedMintingPolicy mkPolicy||]) diff --git a/plutus-ledger/src/Ledger/Tx.hs b/plutus-ledger/src/Ledger/Tx.hs index 70501e3..f34cf63 100644 --- a/plutus-ledger/src/Ledger/Tx.hs +++ b/plutus-ledger/src/Ledger/Tx.hs @@ -91,9 +91,10 @@ where import Cardano.Api (TxBodyContent (txValidityUpperBound)) import Cardano.Api qualified as C -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) +import Cardano.Api.Experimental.Certificate qualified as C.Exp import Cardano.Ledger.Alonzo.TxWits (txwitsVKey) import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (DijkstraTx), pattern MkDijkstraTx) import Codec.Serialise (Serialise) import Control.Lens ( Getter, @@ -257,7 +258,7 @@ toDecoratedTxOut (TxOut (C.TxOut addr' val dt rs)) = (toDecoratedDatum dt) (CardanoAPI.fromCardanoReferenceScript rs) where - toDecoratedDatum :: C.TxOutDatum C.CtxTx C.ConwayEra -> Maybe (V2.DatumHash, DatumFromQuery) + toDecoratedDatum :: C.TxOutDatum C.CtxTx C.DijkstraEra -> Maybe (V2.DatumHash, DatumFromQuery) toDecoratedDatum C.TxOutDatumNone = Nothing toDecoratedDatum (C.TxOutDatumHash _ h) = @@ -284,7 +285,7 @@ toTxOut networkId p = ) toTxOutDatum :: - Maybe (V2.DatumHash, DatumFromQuery) -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.ConwayEra) + Maybe (V2.DatumHash, DatumFromQuery) -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.DijkstraEra) toTxOutDatum = CardanoAPI.toCardanoTxOutDatum . toPlutusOutputDatum -- | Converts a transaction output from the chain index to the plutus-ledger-api @@ -364,7 +365,7 @@ instance Pretty CardanoAPI.CardanoBuildTx where Right tx -> pretty $ CardanoEmulatorEraTx tx _ -> viaShow txBodyContent -getTxBodyContent :: CardanoTx -> C.TxBodyContent C.ViewTx C.ConwayEra +getTxBodyContent :: CardanoTx -> C.TxBodyContent C.ViewTx C.DijkstraEra getTxBodyContent (CardanoEmulatorEraTx tx) = C.getTxBodyContent $ C.getTxBody tx getCardanoTxId :: CardanoTx -> C.TxId @@ -410,7 +411,7 @@ getCardanoTxSpentOutputs = Set.fromList . getCardanoTxInputs getCardanoTxReturnCollateral :: CardanoTx -> Maybe TxOut getCardanoTxReturnCollateral = getTxBodyContentReturnCollateral . getTxBodyContent -getTxBodyContentReturnCollateral :: C.TxBodyContent ctx C.ConwayEra -> Maybe TxOut +getTxBodyContentReturnCollateral :: C.TxBodyContent ctx C.DijkstraEra -> Maybe TxOut getTxBodyContentReturnCollateral C.TxBodyContent {..} = case txReturnCollateral of C.TxReturnCollateralNone -> Nothing @@ -442,7 +443,7 @@ getCardanoTxValidityRange (CardanoTx tx _) = getCardanoTxData :: CardanoTx -> Map V1.DatumHash V1.Datum getCardanoTxData (CardanoEmulatorEraTx (C.Tx txBody _)) = fst $ CardanoAPI.scriptDataFromCardanoTxBody txBody -getTxBodyContentCerts :: C.TxBodyContent ctx era -> [C.Certificate era] +getTxBodyContentCerts :: C.TxBodyContent ctx era -> [C.Exp.Certificate (C.ShelleyLedgerEra era)] getTxBodyContentCerts C.TxBodyContent {..} = case txCertificates of C.TxCertificatesNone -> mempty C.TxCertificates _ certs -> fst <$> OMap.toAscList certs @@ -451,11 +452,11 @@ getTxBodyContentCerts C.TxBodyContent {..} = case txCertificates of txBodyContentIns :: Lens' - (C.TxBodyContent C.BuildTx C.ConwayEra) - [(C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.ConwayEra))] + (C.TxBodyContent C.BuildTx C.DijkstraEra) + [(C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.DijkstraEra))] txBodyContentIns = lens C.txIns (\bodyContent ins -> bodyContent {C.txIns = ins}) -txBodyContentCollateralIns :: Lens' (C.TxBodyContent C.BuildTx C.ConwayEra) [C.TxIn] +txBodyContentCollateralIns :: Lens' (C.TxBodyContent C.BuildTx C.DijkstraEra) [C.TxIn] txBodyContentCollateralIns = lens ( \bodyContent -> case C.txInsCollateral bodyContent of @@ -464,11 +465,11 @@ txBodyContentCollateralIns = ) ( \bodyContent ins -> bodyContent - { C.txInsCollateral = case ins of [] -> C.TxInsCollateralNone; _ -> C.TxInsCollateral C.AlonzoEraOnwardsConway ins + { C.txInsCollateral = case ins of [] -> C.TxInsCollateralNone; _ -> C.TxInsCollateral C.AlonzoEraOnwardsDijkstra ins } ) -txBodyContentOuts :: Lens' (C.TxBodyContent ctx C.ConwayEra) [TxOut] +txBodyContentOuts :: Lens' (C.TxBodyContent ctx C.DijkstraEra) [TxOut] txBodyContentOuts = lens (map TxOut . C.txOuts) (\bodyContent outs -> bodyContent {C.txOuts = map getTxOut outs}) getCardanoTxRedeemers :: CardanoTx -> V2.Tx.Redeemers @@ -482,8 +483,8 @@ getCardanoTxExtraKeyWitnesses (CardanoEmulatorEraTx tx) = case C.txExtraKeyWits addCardanoTxWitness :: C.ShelleyWitnessSigningKey -> CardanoTx -> CardanoTx addCardanoTxWitness witness (CardanoEmulatorEraTx ctx) = CardanoEmulatorEraTx (addWitness ctx) where - addWitness (C.ShelleyTx shelleyBasedEra (AlonzoTx body wits isValid aux)) = - C.ShelleyTx shelleyBasedEra (AlonzoTx body wits' isValid aux) + addWitness (C.ShelleyTx shelleyBasedEra (MkDijkstraTx (DijkstraTx body wits isValid aux))) = + C.ShelleyTx shelleyBasedEra (MkDijkstraTx (DijkstraTx body wits' isValid aux)) where wits' = wits <> mempty {txwitsVKey = newWits} newWits = case fromShelleyWitnessSigningKey body of @@ -493,7 +494,7 @@ addCardanoTxWitness witness (CardanoEmulatorEraTx ctx) = CardanoEmulatorEraTx (a fromShelleyWitnessSigningKey txBody = C.makeShelleyKeyWitness C.shelleyBasedEra - (C.ShelleyTxBody C.ShelleyBasedEraConway txBody notUsed notUsed notUsed notUsed) + (C.ShelleyTxBody C.ShelleyBasedEraDijkstra txBody notUsed notUsed notUsed notUsed) witness where notUsed = undefined -- hack so we can reuse code from cardano-api diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs index 833234c..8ea51c7 100644 --- a/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs +++ b/plutus-ledger/src/Ledger/Tx/CardanoAPI.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | @@ -33,11 +34,9 @@ module Ledger.Tx.CardanoAPI where import Cardano.Api qualified as C -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) import Cardano.Ledger.BaseTypes (mkTxIxPartial) -import Cardano.Ledger.Conway qualified as Conway -import Cardano.Ledger.Conway.TxBody (ConwayTxBody (ConwayTxBody, ctbReqSignerHashes)) import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Dijkstra qualified as Dijkstra import Cardano.Ledger.Shelley.API qualified as C.Ledger import Data.Bifunctor (bimap) import Data.Map qualified as Map @@ -54,7 +53,7 @@ toCardanoMintWitness :: PV1.Redeemer -> Maybe (P.Versioned PV3.TxOutRef) -> Maybe (P.Versioned PV1.MintingPolicy) -> - Either ToCardanoError (C.ScriptWitness C.WitCtxMint C.ConwayEra) + Either ToCardanoError (C.ScriptWitness C.WitCtxMint C.DijkstraEra) toCardanoMintWitness _ Nothing Nothing = Left MissingMintingPolicy toCardanoMintWitness redeemer (Just ref) _ = toCardanoScriptWitness C.NoScriptDatumForMint redeemer (Right ref) @@ -66,7 +65,7 @@ toCardanoScriptWitness :: C.ScriptDatum witctx -> a -> Either (P.Versioned PV1.Script) (P.Versioned PV3.TxOutRef) -> - Either ToCardanoError (C.ScriptWitness witctx C.ConwayEra) + Either ToCardanoError (C.ScriptWitness witctx C.DijkstraEra) toCardanoScriptWitness datum redeemer scriptOrRef = ( case scriptOrRef of Left script -> pure $ toCardanoTxInScriptWitnessHeader script @@ -84,7 +83,7 @@ toCardanoDatumWitness :: Maybe PV1.Datum -> C.ScriptDatum C.WitCtxTxIn toCardanoDatumWitness = maybe C.InlineScriptDatum (C.ScriptDatumForTxIn . Just . toCardanoScriptData . PV1.getDatum) type WitnessHeader witctx = - C.ScriptDatum witctx -> C.ScriptRedeemer -> C.ExecutionUnits -> C.ScriptWitness witctx C.ConwayEra + C.ScriptDatum witctx -> C.ScriptRedeemer -> C.ExecutionUnits -> C.ScriptWitness witctx C.DijkstraEra toCardanoTxInReferenceWitnessHeader :: P.Versioned PV3.TxOutRef -> Either ToCardanoError (WitnessHeader witctx) @@ -92,11 +91,11 @@ toCardanoTxInReferenceWitnessHeader (P.Versioned ref lang) = do txIn <- toCardanoTxIn ref pure $ case lang of P.PlutusV1 -> - C.PlutusScriptWitness C.PlutusScriptV1InConway C.PlutusScriptV1 $ C.PReferenceScript txIn + C.PlutusScriptWitness C.PlutusScriptV1InDijkstra C.PlutusScriptV1 $ C.PReferenceScript txIn P.PlutusV2 -> - C.PlutusScriptWitness C.PlutusScriptV2InConway C.PlutusScriptV2 $ C.PReferenceScript txIn + C.PlutusScriptWitness C.PlutusScriptV2InDijkstra C.PlutusScriptV2 $ C.PReferenceScript txIn P.PlutusV3 -> - C.PlutusScriptWitness C.PlutusScriptV3InConway C.PlutusScriptV3 $ C.PReferenceScript txIn + C.PlutusScriptWitness C.PlutusScriptV3InDijkstra C.PlutusScriptV3 $ C.PReferenceScript txIn toCardanoTxInScriptWitnessHeader :: P.Versioned PV1.Script -> WitnessHeader witctx toCardanoTxInScriptWitnessHeader script = @@ -105,31 +104,30 @@ toCardanoTxInScriptWitnessHeader script = C.ScriptInEra era (C.PlutusScript v s) -> C.PlutusScriptWitness era v (C.PScript s) -fromCardanoTotalCollateral :: C.TxTotalCollateral C.ConwayEra -> Maybe C.Ledger.Coin +fromCardanoTotalCollateral :: C.TxTotalCollateral C.DijkstraEra -> Maybe C.Ledger.Coin fromCardanoTotalCollateral C.TxTotalCollateralNone = Nothing fromCardanoTotalCollateral (C.TxTotalCollateral _ lv) = Just lv -toCardanoTotalCollateral :: Maybe C.Ledger.Coin -> C.TxTotalCollateral C.ConwayEra +toCardanoTotalCollateral :: Maybe C.Ledger.Coin -> C.TxTotalCollateral C.DijkstraEra toCardanoTotalCollateral = maybe C.TxTotalCollateralNone - (C.TxTotalCollateral C.BabbageEraOnwardsConway) + (C.TxTotalCollateral C.BabbageEraOnwardsDijkstra) -fromCardanoReturnCollateral :: C.TxReturnCollateral C.CtxTx C.ConwayEra -> Maybe P.TxOut +fromCardanoReturnCollateral :: C.TxReturnCollateral C.CtxTx C.DijkstraEra -> Maybe P.TxOut fromCardanoReturnCollateral C.TxReturnCollateralNone = Nothing fromCardanoReturnCollateral (C.TxReturnCollateral _ txOut) = Just $ P.TxOut txOut -toCardanoReturnCollateral :: Maybe P.TxOut -> C.TxReturnCollateral C.CtxTx C.ConwayEra +toCardanoReturnCollateral :: Maybe P.TxOut -> C.TxReturnCollateral C.CtxTx C.DijkstraEra toCardanoReturnCollateral = maybe C.TxReturnCollateralNone - (C.TxReturnCollateral C.BabbageEraOnwardsConway . P.getTxOut) + (C.TxReturnCollateral C.BabbageEraOnwardsDijkstra . P.getTxOut) -getRequiredSigners :: C.Tx C.ConwayEra -> [P.PaymentPubKeyHash] -getRequiredSigners (C.ShelleyTx _ (AlonzoTx ConwayTxBody {ctbReqSignerHashes = rsq} _ _ _)) = - foldMap - (pure . P.PaymentPubKeyHash . P.toPlutusPubKeyHash . C.PaymentKeyHash . C.Ledger.coerceKeyRole) - rsq +getRequiredSigners :: C.Tx C.DijkstraEra -> [P.PaymentPubKeyHash] +getRequiredSigners tx = case C.txExtraKeyWits (C.getTxBodyContent (C.getTxBody tx)) of + C.TxExtraKeyWitnessesNone -> [] + C.TxExtraKeyWitnesses _ txwits -> map (P.PaymentPubKeyHash . P.toPlutusPubKeyHash) txwits toPlutusIndex :: C.Ledger.UTxO EmulatorEra -> @@ -137,12 +135,12 @@ toPlutusIndex :: toPlutusIndex (C.Ledger.UTxO utxo) = C.UTxO . Map.fromList - . map (bimap C.fromShelleyTxIn (C.fromShelleyTxOut C.ShelleyBasedEraConway)) + . map (bimap C.fromShelleyTxIn (C.fromShelleyTxOut C.ShelleyBasedEraDijkstra)) . Map.toList $ utxo -fromPlutusIndex :: P.UtxoIndex -> C.Ledger.UTxO Conway.ConwayEra -fromPlutusIndex = C.toLedgerUTxO C.ShelleyBasedEraConway +fromPlutusIndex :: P.UtxoIndex -> C.Ledger.UTxO Dijkstra.DijkstraEra +fromPlutusIndex = C.toLedgerUTxO C.ShelleyBasedEraDijkstra fromPlutusTxOutRef :: PV3.TxOutRef -> Either ToCardanoError C.Ledger.TxIn fromPlutusTxOutRef (PV3.TxOutRef txId i) = C.Ledger.TxIn <$> fromPlutusTxId txId <*> pure (mkTxIxPartial i) @@ -150,5 +148,5 @@ fromPlutusTxOutRef (PV3.TxOutRef txId i) = C.Ledger.TxIn <$> fromPlutusTxId txId fromPlutusTxId :: PV3.TxId -> Either ToCardanoError C.Ledger.TxId fromPlutusTxId = fmap C.toShelleyTxId . toCardanoTxId -fromPlutusTxOut :: P.TxOut -> Ledger.TxOut Conway.ConwayEra -fromPlutusTxOut = C.toShelleyTxOut C.ShelleyBasedEraConway . P.toCtxUTxOTxOut +fromPlutusTxOut :: P.TxOut -> Ledger.TxOut Dijkstra.DijkstraEra +fromPlutusTxOut = C.toShelleyTxOut C.ShelleyBasedEraDijkstra . P.toCtxUTxOTxOut diff --git a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs index 1a8d79e..ef0a6f0 100644 --- a/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs +++ b/plutus-ledger/src/Ledger/Tx/CardanoAPI/Internal.hs @@ -92,13 +92,12 @@ module Ledger.Tx.CardanoAPI.Internal where import Cardano.Api qualified as C -import Cardano.BM.Data.Tracer (ToObject) import Cardano.Chain.Common (addrToBase58) import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo import Cardano.Ledger.Alonzo.TxWits qualified as Alonzo import Cardano.Ledger.Coin (Coin (Coin)) -import Cardano.Ledger.Conway (ConwayEra) -import Cardano.Ledger.Conway.Scripts qualified as Conway +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Dijkstra.Scripts qualified as Dijkstra import Cardano.Ledger.Core qualified as Ledger import Control.Lens ((<&>)) import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, (.:), (.=)) @@ -129,20 +128,20 @@ import PlutusLedgerApi.V3 qualified as PV3 import PlutusTx.Prelude qualified as PlutusTx import Prettyprinter (Pretty (pretty), colon, viaShow, (<+>)) -type EmulatorEra = ConwayEra +type EmulatorEra = DijkstraEra -newtype CardanoBuildTx = CardanoBuildTx {getCardanoBuildTx :: C.TxBodyContent C.BuildTx C.ConwayEra} +newtype CardanoBuildTx = CardanoBuildTx {getCardanoBuildTx :: C.TxBodyContent C.BuildTx C.DijkstraEra} deriving (Show, Eq, Generic) -- | Cardano tx from any era. data CardanoTx where CardanoTx :: C.Tx era -> C.ShelleyBasedEra era -> CardanoTx -getEmulatorEraTx :: CardanoTx -> C.Tx C.ConwayEra -getEmulatorEraTx (CardanoTx tx C.ShelleyBasedEraConway) = tx -getEmulatorEraTx _ = error "getEmulatorEraTx: Expected a Conway tx" +getEmulatorEraTx :: CardanoTx -> C.Tx C.DijkstraEra +getEmulatorEraTx (CardanoTx tx C.ShelleyBasedEraDijkstra) = tx +getEmulatorEraTx _ = error "getEmulatorEraTx: Expected a Dijkstra tx" -pattern CardanoEmulatorEraTx :: C.Tx C.ConwayEra -> CardanoTx +pattern CardanoEmulatorEraTx :: C.Tx C.DijkstraEra -> CardanoTx pattern CardanoEmulatorEraTx tx <- (getEmulatorEraTx -> tx) where CardanoEmulatorEraTx tx = CardanoTx tx C.shelleyBasedEra @@ -155,7 +154,7 @@ instance Eq CardanoTx where (CardanoTx tx1 C.ShelleyBasedEraMary) == (CardanoTx tx2 C.ShelleyBasedEraMary) = tx1 == tx2 (CardanoTx tx1 C.ShelleyBasedEraAlonzo) == (CardanoTx tx2 C.ShelleyBasedEraAlonzo) = tx1 == tx2 (CardanoTx tx1 C.ShelleyBasedEraBabbage) == (CardanoTx tx2 C.ShelleyBasedEraBabbage) = tx1 == tx2 - (CardanoTx tx1 C.ShelleyBasedEraConway) == (CardanoTx tx2 C.ShelleyBasedEraConway) = tx1 == tx2 + (CardanoTx tx1 C.ShelleyBasedEraDijkstra) == (CardanoTx tx2 C.ShelleyBasedEraDijkstra) = tx1 == tx2 _ == _ = False deriving instance Show CardanoTx @@ -221,8 +220,8 @@ toTxScriptValidity C.ShelleyBasedEraAlonzo True = C.TxScriptValidity C.AlonzoEra toTxScriptValidity C.ShelleyBasedEraAlonzo False = C.TxScriptValidity C.AlonzoEraOnwardsAlonzo C.ScriptInvalid toTxScriptValidity C.ShelleyBasedEraBabbage True = C.TxScriptValidity C.AlonzoEraOnwardsBabbage C.ScriptValid toTxScriptValidity C.ShelleyBasedEraBabbage False = C.TxScriptValidity C.AlonzoEraOnwardsBabbage C.ScriptInvalid -toTxScriptValidity C.ShelleyBasedEraConway True = C.TxScriptValidity C.AlonzoEraOnwardsConway C.ScriptValid -toTxScriptValidity C.ShelleyBasedEraConway False = C.TxScriptValidity C.AlonzoEraOnwardsConway C.ScriptInvalid +toTxScriptValidity C.ShelleyBasedEraDijkstra True = C.TxScriptValidity C.AlonzoEraOnwardsDijkstra C.ScriptValid +toTxScriptValidity C.ShelleyBasedEraDijkstra False = C.TxScriptValidity C.AlonzoEraOnwardsDijkstra C.ScriptInvalid toTxScriptValidity _ _ = C.TxScriptValidityNone withShelleyBasedEraConstraintsForLedger :: @@ -233,18 +232,18 @@ withShelleyBasedEraConstraintsForLedger = \case C.ShelleyBasedEraMary -> id C.ShelleyBasedEraAlonzo -> id C.ShelleyBasedEraBabbage -> id - C.ShelleyBasedEraConway -> id + C.ShelleyBasedEraDijkstra -> id -- | Given a 'C.TxBody from a 'C.Tx era', return the datums and redeemers along -- with their hashes. scriptDataFromCardanoTxBody :: - C.TxBody C.ConwayEra -> + C.TxBody C.DijkstraEra -> (Map P.DatumHash P.Datum, PV1.Redeemers) -- scriptDataFromCardanoTxBody C.ByronTxBody{} = (mempty, mempty) scriptDataFromCardanoTxBody (C.ShelleyTxBody _ _ _ C.TxBodyNoScriptData _ _) = (mempty, mempty) scriptDataFromCardanoTxBody - (C.ShelleyTxBody shelleyBasedEra _ _ (C.TxBodyScriptData _ (Alonzo.TxDats' dats) reds') _ _) = + (C.ShelleyTxBody shelleyBasedEra _ _ (C.TxBodyScriptData _ (Alonzo.TxDats dats) reds') _ _) = withShelleyBasedEraConstraintsForLedger shelleyBasedEra $ case reds' of (Alonzo.Redeemers reds) -> let datums = @@ -259,12 +258,13 @@ scriptDataFromCardanoTxBody in (datums, redeemers) redeemerPtrFromCardanoRdmrPtr :: Alonzo.PlutusPurpose Alonzo.AsIx EmulatorEra -> PV1.RedeemerPtr -redeemerPtrFromCardanoRdmrPtr (Conway.ConwaySpending (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Spend (toInteger ix) -redeemerPtrFromCardanoRdmrPtr (Conway.ConwayMinting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Mint (toInteger ix) -redeemerPtrFromCardanoRdmrPtr (Conway.ConwayCertifying (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Cert (toInteger ix) -redeemerPtrFromCardanoRdmrPtr (Conway.ConwayRewarding (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) -redeemerPtrFromCardanoRdmrPtr (Conway.ConwayVoting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) -redeemerPtrFromCardanoRdmrPtr (Conway.ConwayProposing (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraSpending (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Spend (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraMinting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Mint (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraCertifying (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Cert (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraWithdrawing (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraVoting (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraProposing (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) +redeemerPtrFromCardanoRdmrPtr (Dijkstra.DijkstraGuarding (Alonzo.AsIx ix)) = PV1.RedeemerPtr PV1.Reward (toInteger ix) -- | Extract plutus scripts from a Cardano API tx body. -- @@ -288,10 +288,10 @@ fromLedgerScript e s = fromCardanoScriptInEra $ C.fromShelleyBasedScript e s createTransactionBody :: CardanoBuildTx -> - Either ToCardanoError (C.TxBody C.ConwayEra) + Either ToCardanoError (C.TxBody C.DijkstraEra) createTransactionBody (CardanoBuildTx txBodyContent) = first (TxBodyError . C.displayError) $ - C.createTransactionBody C.ShelleyBasedEraConway txBodyContent + C.createTransactionBody C.ShelleyBasedEraDijkstra txBodyContent fromCardanoTxIn :: C.TxIn -> PV3.TxOutRef fromCardanoTxIn (C.TxIn txId (C.TxIx txIx)) = PV3.TxOutRef (fromCardanoTxId txId) (toInteger txIx) @@ -347,7 +347,7 @@ refScriptToScriptHash (C.ReferenceScript _ (C.ScriptInAnyLang _ s)) = toCardanoTxOut :: C.NetworkId -> PV2.TxOut -> - Either ToCardanoError (C.TxOut C.CtxTx C.ConwayEra) + Either ToCardanoError (C.TxOut C.CtxTx C.DijkstraEra) toCardanoTxOut networkId (PV2.TxOut addr value datum _rsHash) = C.TxOut <$> toCardanoAddressInEra networkId addr @@ -378,9 +378,9 @@ fromCardanoAddress (C.ShelleyAddress _ paymentCredential stakeAddressReference) fromCardanoStakeAddressReference (C.fromShelleyStakeReference stakeAddressReference) toCardanoAddressInEra :: - C.NetworkId -> P.Address -> Either ToCardanoError (C.AddressInEra C.ConwayEra) + C.NetworkId -> P.Address -> Either ToCardanoError (C.AddressInEra C.DijkstraEra) toCardanoAddressInEra networkId (P.Address addressCredential addressStakingCredential) = - C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) + C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraDijkstra) <$> ( C.makeShelleyAddress networkId <$> toCardanoPaymentCredential addressCredential <*> toCardanoStakeAddressReference addressStakingCredential @@ -446,7 +446,7 @@ toCardanoStakeKeyHash (PV1.PubKeyHash bs) = fromCardanoTxOutValue :: C.TxOutValue era -> C.Value fromCardanoTxOutValue = C.txOutValueToValue -toCardanoTxOutValue :: C.Value -> C.TxOutValue C.ConwayEra +toCardanoTxOutValue :: C.Value -> C.TxOutValue C.DijkstraEra toCardanoTxOutValue = C.TxOutValueShelleyBased C.shelleyBasedEra . C.toMaryValue fromCardanoTxOutDatumHash :: C.TxOutDatum C.CtxTx era -> Maybe P.DatumHash @@ -483,30 +483,30 @@ fromCardanoTxOutDatum' (C.TxOutDatumHash _ h) = fromCardanoTxOutDatum' (C.TxOutDatumInline _ d) = PV2.OutputDatum $ PV2.Datum $ fromCardanoScriptData d -toCardanoTxOutNoDatum :: C.TxOutDatum C.CtxTx C.ConwayEra +toCardanoTxOutNoDatum :: C.TxOutDatum C.CtxTx C.DijkstraEra toCardanoTxOutNoDatum = C.TxOutDatumNone -toCardanoTxOutDatumInline :: PV2.Datum -> C.TxOutDatum C.CtxTx C.ConwayEra +toCardanoTxOutDatumInline :: PV2.Datum -> C.TxOutDatum C.CtxTx C.DijkstraEra toCardanoTxOutDatumInline = - C.TxOutDatumInline C.BabbageEraOnwardsConway + C.TxOutDatumInline C.BabbageEraOnwardsDijkstra . C.unsafeHashableScriptData . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum -toCardanoTxOutDatumHashFromDatum :: PV2.Datum -> C.TxOutDatum ctx C.ConwayEra +toCardanoTxOutDatumHashFromDatum :: PV2.Datum -> C.TxOutDatum ctx C.DijkstraEra toCardanoTxOutDatumHashFromDatum = - C.TxOutDatumHash C.AlonzoEraOnwardsConway + C.TxOutDatumHash C.AlonzoEraOnwardsDijkstra . C.hashScriptDataBytes . C.unsafeHashableScriptData . C.fromPlutusData . PV2.builtinDataToData . PV2.getDatum -toCardanoTxOutDatumHash :: P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.ConwayEra) -toCardanoTxOutDatumHash datumHash = C.TxOutDatumHash C.AlonzoEraOnwardsConway <$> toCardanoScriptDataHash datumHash +toCardanoTxOutDatumHash :: P.DatumHash -> Either ToCardanoError (C.TxOutDatum ctx C.DijkstraEra) +toCardanoTxOutDatumHash datumHash = C.TxOutDatumHash C.AlonzoEraOnwardsDijkstra <$> toCardanoScriptDataHash datumHash -toCardanoTxOutDatum :: PV2.OutputDatum -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.ConwayEra) +toCardanoTxOutDatum :: PV2.OutputDatum -> Either ToCardanoError (C.TxOutDatum C.CtxTx C.DijkstraEra) toCardanoTxOutDatum PV2.NoOutputDatum = pure toCardanoTxOutNoDatum toCardanoTxOutDatum (PV2.OutputDatum d) = pure $ toCardanoTxOutDatumInline d toCardanoTxOutDatum (PV2.OutputDatumHash dh) = toCardanoTxOutDatumHash dh @@ -576,7 +576,7 @@ toCardanoAssetId (Value.AssetClass (currencySymbol, tokenName)) fromCardanoFee :: C.TxFee era -> Coin fromCardanoFee (C.TxFeeExplicit _ lovelace) = lovelace -toCardanoFee :: Coin -> C.TxFee C.ConwayEra +toCardanoFee :: Coin -> C.TxFee C.DijkstraEra toCardanoFee = C.TxFeeExplicit C.shelleyBasedEra fromCardanoLovelace :: Coin -> PV1.Value @@ -595,7 +595,7 @@ fromCardanoValidityRange l u = PV1.Interval (fromCardanoValidityLowerBound l) (f toCardanoValidityRange :: P.SlotRange -> - Either ToCardanoError (C.TxValidityLowerBound C.ConwayEra, C.TxValidityUpperBound C.ConwayEra) + Either ToCardanoError (C.TxValidityLowerBound C.DijkstraEra, C.TxValidityUpperBound C.DijkstraEra) toCardanoValidityRange (PV1.Interval l u) = (,) <$> toCardanoValidityLowerBound l <*> toCardanoValidityUpperBound u fromCardanoValidityLowerBound :: C.TxValidityLowerBound era -> PV1.LowerBound P.Slot @@ -603,11 +603,11 @@ fromCardanoValidityLowerBound C.TxValidityNoLowerBound = PV1.LowerBound PV1.NegI fromCardanoValidityLowerBound (C.TxValidityLowerBound _ slotNo) = PV1.LowerBound (PV1.Finite $ fromCardanoSlotNo slotNo) True toCardanoValidityLowerBound :: - PV1.LowerBound P.Slot -> Either ToCardanoError (C.TxValidityLowerBound C.ConwayEra) + PV1.LowerBound P.Slot -> Either ToCardanoError (C.TxValidityLowerBound C.DijkstraEra) toCardanoValidityLowerBound (PV1.LowerBound PV1.NegInf _) = pure C.TxValidityNoLowerBound toCardanoValidityLowerBound (PV1.LowerBound (PV1.Finite slotNo) closed) = pure - . C.TxValidityLowerBound C.AllegraEraOnwardsConway + . C.TxValidityLowerBound C.AllegraEraOnwardsDijkstra . toCardanoSlotNo $ if slotNo < 0 then 0 else if closed then slotNo else slotNo + 1 toCardanoValidityLowerBound (PV1.LowerBound PV1.PosInf _) = Left InvalidValidityRange @@ -617,7 +617,7 @@ fromCardanoValidityUpperBound (C.TxValidityUpperBound _ Nothing) = PV1.UpperBoun fromCardanoValidityUpperBound (C.TxValidityUpperBound _ (Just slotNo)) = PV1.UpperBound (PV1.Finite $ fromCardanoSlotNo slotNo) False toCardanoValidityUpperBound :: - PV1.UpperBound P.Slot -> Either ToCardanoError (C.TxValidityUpperBound C.ConwayEra) + PV1.UpperBound P.Slot -> Either ToCardanoError (C.TxValidityUpperBound C.DijkstraEra) toCardanoValidityUpperBound (PV1.UpperBound PV1.PosInf _) = pure $ C.TxValidityUpperBound C.shelleyBasedEra Nothing toCardanoValidityUpperBound (PV1.UpperBound (PV1.Finite slotNo) closed) = pure . C.TxValidityUpperBound C.shelleyBasedEra . Just . toCardanoSlotNo $ @@ -643,23 +643,28 @@ fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InBabbage (C.PlutusScript Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV1) fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV2InBabbage (C.PlutusScript C.PlutusScriptV2 script)) = Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV2) -fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InConway (C.PlutusScript C.PlutusScriptV1 script)) = +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InDijkstra (C.PlutusScript C.PlutusScriptV1 script)) = Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV1) -fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV2InConway (C.PlutusScript C.PlutusScriptV2 script)) = +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV2InDijkstra (C.PlutusScript C.PlutusScriptV2 script)) = Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV2) -fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV3InConway (C.PlutusScript C.PlutusScriptV3 script)) = +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV3InDijkstra (C.PlutusScript C.PlutusScriptV3 script)) = Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV3) +fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV4InDijkstra (C.PlutusScript C.PlutusScriptV4 script)) = + Just (P.Versioned (fromCardanoPlutusScript script) P.PlutusV4) fromCardanoScriptInEra (C.ScriptInEra _ C.SimpleScript {}) = Nothing -toCardanoScriptInEra :: P.Versioned P.Script -> C.ScriptInEra C.ConwayEra +toCardanoScriptInEra :: P.Versioned P.Script -> C.ScriptInEra C.DijkstraEra toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV1) = - C.ScriptInEra C.PlutusScriptV1InConway . C.PlutusScript C.PlutusScriptV1 $ + C.ScriptInEra C.PlutusScriptV1InDijkstra . C.PlutusScript C.PlutusScriptV1 $ C.PlutusScriptSerialised s toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV2) = - C.ScriptInEra C.PlutusScriptV2InConway . C.PlutusScript C.PlutusScriptV2 $ + C.ScriptInEra C.PlutusScriptV2InDijkstra . C.PlutusScript C.PlutusScriptV2 $ C.PlutusScriptSerialised s toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV3) = - C.ScriptInEra C.PlutusScriptV3InConway . C.PlutusScript C.PlutusScriptV3 $ + C.ScriptInEra C.PlutusScriptV3InDijkstra . C.PlutusScript C.PlutusScriptV3 $ + C.PlutusScriptSerialised s +toCardanoScriptInEra (P.Versioned (P.Script s) P.PlutusV4) = + C.ScriptInEra C.PlutusScriptV4InDijkstra . C.PlutusScript C.PlutusScriptV4 $ C.PlutusScriptSerialised s fromCardanoPlutusScript :: C.PlutusScript lang -> P.Script @@ -671,6 +676,7 @@ fromCardanoScriptInAnyLang (C.ScriptInAnyLang _sl (C.PlutusScript psv ps)) = Jus C.PlutusScriptV1 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV1 C.PlutusScriptV2 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV2 C.PlutusScriptV3 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV3 + C.PlutusScriptV4 -> P.Versioned (fromCardanoPlutusScript ps) P.PlutusV4 toCardanoScriptInAnyLang :: P.Versioned P.Script -> C.ScriptInAnyLang toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV1) = @@ -682,14 +688,17 @@ toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV2) = toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV3) = C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV3) . C.PlutusScript C.PlutusScriptV3 $ C.PlutusScriptSerialised s +toCardanoScriptInAnyLang (P.Versioned (P.Script s) P.PlutusV4) = + C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV4) . C.PlutusScript C.PlutusScriptV4 $ + C.PlutusScriptSerialised s -fromCardanoReferenceScript :: C.ReferenceScript C.ConwayEra -> Maybe (P.Versioned P.Script) +fromCardanoReferenceScript :: C.ReferenceScript C.DijkstraEra -> Maybe (P.Versioned P.Script) fromCardanoReferenceScript C.ReferenceScriptNone = Nothing fromCardanoReferenceScript (C.ReferenceScript _ script) = fromCardanoScriptInAnyLang script -toCardanoReferenceScript :: Maybe (P.Versioned P.Script) -> C.ReferenceScript C.ConwayEra +toCardanoReferenceScript :: Maybe (P.Versioned P.Script) -> C.ReferenceScript C.DijkstraEra toCardanoReferenceScript (Just script) = - C.ReferenceScript C.BabbageEraOnwardsConway $ toCardanoScriptInAnyLang script + C.ReferenceScript C.BabbageEraOnwardsDijkstra $ toCardanoScriptInAnyLang script toCardanoReferenceScript Nothing = C.ReferenceScriptNone deserialiseFromRawBytes :: @@ -702,7 +711,7 @@ tag s = first (Tag s) data FromCardanoError = SimpleScriptsNotSupported deriving stock (Show, Eq, Generic) - deriving anyclass (FromJSON, ToJSON, ToObject) + deriving anyclass (FromJSON, ToJSON) instance Pretty FromCardanoError where pretty SimpleScriptsNotSupported = "Simple scripts are not supported" diff --git a/plutus-ledger/src/Ledger/Tx/Internal.hs b/plutus-ledger/src/Ledger/Tx/Internal.hs index f748dff..b06f47c 100644 --- a/plutus-ledger/src/Ledger/Tx/Internal.hs +++ b/plutus-ledger/src/Ledger/Tx/Internal.hs @@ -21,6 +21,7 @@ where import Cardano.Api (TxBodyContent (txValidityLowerBound)) import Cardano.Api qualified as C import Cardano.Ledger.Alonzo.Genesis () +import Cardano.Ledger.Core qualified as Ledger import Codec.Serialise (Serialise, decode, encode) import Control.Lens qualified as L import Data.Aeson (FromJSON, ToJSON) @@ -48,13 +49,13 @@ cardanoTxOutValue (C.TxOut _aie tov _tod _rs) = txOutValue :: TxOut -> C.Value txOutValue = cardanoTxOutValue . getTxOut -outValue :: L.Lens TxOut TxOut C.Value (C.TxOutValue C.ConwayEra) +outValue :: L.Lens TxOut TxOut C.Value (C.TxOutValue C.DijkstraEra) outValue = L.lens txOutValue (\(TxOut (C.TxOut aie _ tod rs)) tov -> TxOut (C.TxOut aie tov tod rs)) -outValue' :: L.Lens' TxOut (C.TxOutValue C.ConwayEra) +outValue' :: L.Lens' TxOut (C.TxOutValue C.DijkstraEra) outValue' = L.lens (\(TxOut (C.TxOut _aie tov _tod _rs)) -> tov) @@ -86,22 +87,22 @@ data Certificate = Certificate instance Pretty Certificate where pretty = viaShow -newtype TxOut = TxOut {getTxOut :: C.TxOut C.CtxTx C.ConwayEra} +newtype TxOut = TxOut {getTxOut :: C.TxOut C.CtxTx C.DijkstraEra} deriving stock (Show, Eq, Generic) deriving anyclass (ToJSON, FromJSON) deriving newtype (Pretty) instance C.ToCBOR TxOut where - toCBOR = C.toCBOR . C.toShelleyTxOut C.ShelleyBasedEraConway . toCtxUTxOTxOut + toCBOR = Ledger.toEraCBOR @(C.ShelleyLedgerEra C.DijkstraEra) . C.toShelleyTxOut C.ShelleyBasedEraDijkstra . toCtxUTxOTxOut instance C.FromCBOR TxOut where - fromCBOR = TxOut . C.fromShelleyTxOut C.ShelleyBasedEraConway <$> C.fromCBOR + fromCBOR = TxOut . C.fromShelleyTxOut C.ShelleyBasedEraDijkstra <$> Ledger.fromEraCBOR @(C.ShelleyLedgerEra C.DijkstraEra) instance Serialise TxOut where encode = C.toCBOR decode = C.fromCBOR -toCtxUTxOTxOut :: TxOut -> C.TxOut C.CtxUTxO C.ConwayEra +toCtxUTxOTxOut :: TxOut -> C.TxOut C.CtxUTxO C.DijkstraEra toCtxUTxOTxOut = C.toCtxUTxOTxOut . getTxOut type ScriptsMap = Map ScriptHash (Versioned Script) @@ -133,7 +134,7 @@ txOutDatum (TxOut (C.TxOut _aie _tov tod _rs)) = C.TxOutSupplementalDatum _era scriptData -> fromData @d $ C.toPlutusData $ C.getScriptData scriptData -cardanoTxOutDatumHash :: C.TxOutDatum C.CtxUTxO C.ConwayEra -> Maybe (C.Hash C.ScriptData) +cardanoTxOutDatumHash :: C.TxOutDatum C.CtxUTxO C.DijkstraEra -> Maybe (C.Hash C.ScriptData) cardanoTxOutDatumHash = \case C.TxOutDatumNone -> Nothing @@ -147,19 +148,19 @@ txOutPubKey (TxOut (C.TxOut aie _ _ _)) = cardanoPubKeyHash aie txOutAddress :: TxOut -> CardanoAddress txOutAddress (TxOut (C.TxOut aie _tov _tod _rs)) = aie -outAddress :: L.Lens' TxOut (C.AddressInEra C.ConwayEra) +outAddress :: L.Lens' TxOut (C.AddressInEra C.DijkstraEra) outAddress = L.lens txOutAddress (\(TxOut (C.TxOut _ tov tod rs)) aie -> TxOut (C.TxOut aie tov tod rs)) -outDatumHash :: L.Lens TxOut TxOut (Maybe DatumHash) (C.TxOutDatum C.CtxTx C.ConwayEra) +outDatumHash :: L.Lens TxOut TxOut (Maybe DatumHash) (C.TxOutDatum C.CtxTx C.DijkstraEra) outDatumHash = L.lens txOutDatumHash (\(TxOut (C.TxOut aie tov _ rs)) tod -> TxOut (C.TxOut aie tov tod rs)) -type ReferenceScript = C.ReferenceScript C.ConwayEra +type ReferenceScript = C.ReferenceScript C.DijkstraEra txOutReferenceScript :: TxOut -> ReferenceScript txOutReferenceScript (TxOut (C.TxOut _aie _tov _tod rs)) = rs @@ -182,7 +183,7 @@ lookupMintingPolicy txScripts = (fmap . fmap) MintingPolicy . lookupScript txScr lookupStakeValidator :: ScriptsMap -> StakeValidatorHash -> Maybe (Versioned StakeValidator) lookupStakeValidator txScripts = (fmap . fmap) StakeValidator . lookupScript txScripts . toScriptHash -emptyTxBodyContent :: C.TxBodyContent C.BuildTx C.ConwayEra +emptyTxBodyContent :: C.TxBodyContent C.BuildTx C.DijkstraEra emptyTxBodyContent = C.TxBodyContent { txIns = [], diff --git a/plutus-ledger/src/Ledger/Tx/Orphans.hs b/plutus-ledger/src/Ledger/Tx/Orphans.hs index 5e5d506..f737184 100644 --- a/plutus-ledger/src/Ledger/Tx/Orphans.hs +++ b/plutus-ledger/src/Ledger/Tx/Orphans.hs @@ -33,15 +33,15 @@ import Ledger.Tx.Orphans.V2 () import Ledger.Value.Orphans () import Prettyprinter (Pretty (pretty), hang, viaShow, vsep, (<+>)) -instance ToJSON (C.Tx C.ConwayEra) where +instance ToJSON (C.Tx C.DijkstraEra) where toJSON tx = object ["tx" .= C.serialiseToTextEnvelope Nothing tx] -instance FromJSON (C.Tx C.ConwayEra) where +instance FromJSON (C.Tx C.DijkstraEra) where parseJSON (Object v) = do envelope <- v .: "tx" either - (const $ parseFail "Failed to parse ConwayEra 'tx' field from CardanoTx") + (const $ parseFail "Failed to parse DijkstraEra 'tx' field from CardanoTx") pure $ C.deserialiseFromTextEnvelope envelope parseJSON invalid = diff --git a/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs b/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs index c9f7323..8093c48 100644 --- a/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs +++ b/plutus-ledger/test/Ledger/Tx/CardanoAPISpec.hs @@ -67,7 +67,7 @@ tests = ] genValueDefault :: Gen C.Value -genValueDefault = C.fromMaryValue <$> Gen.genValueDefault C.MaryEraOnwardsConway +genValueDefault = C.fromMaryValue <$> Gen.genValueDefault C.MaryEraOnwardsDijkstra cardanoAssetNameRoundTrip :: Property cardanoAssetNameRoundTrip = property $ do diff --git a/plutus-ledger/test/Spec.hs b/plutus-ledger/test/Spec.hs index fb555a8..ac62311 100644 --- a/plutus-ledger/test/Spec.hs +++ b/plutus-ledger/test/Spec.hs @@ -147,7 +147,7 @@ txInOrdInstanceEquivalenceTest = property $ do genCardanoBuildTx :: Hedgehog.Gen CardanoBuildTx genCardanoBuildTx = do - tx <- Gen.genTxBodyContent C.ShelleyBasedEraConway + tx <- Gen.genTxBodyContent C.ShelleyBasedEraDijkstra let tx' = tx { C.txCertificates = C.TxCertificatesNone, @@ -171,7 +171,7 @@ genCardanoTx = genMaryEraInCardanoModeTx, genAlonzoEraInCardanoModeTx, genBabbageEraInCardanoModeTx, - genConwayEraInCardanoModeTx + genDijkstraEraInCardanoModeTx ] genShelleyEraInCardanoModeTx :: Hedgehog.Gen CardanoTx @@ -199,7 +199,7 @@ genBabbageEraInCardanoModeTx = do tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraBabbage pure $ CardanoTx tx C.ShelleyBasedEraBabbage -genConwayEraInCardanoModeTx :: Hedgehog.Gen CardanoTx -genConwayEraInCardanoModeTx = do - tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraConway - pure $ CardanoTx tx C.ShelleyBasedEraConway +genDijkstraEraInCardanoModeTx :: Hedgehog.Gen CardanoTx +genDijkstraEraInCardanoModeTx = do + tx <- fromGenT $ Gen.genTx C.ShelleyBasedEraDijkstra + pure $ CardanoTx tx C.ShelleyBasedEraDijkstra diff --git a/plutus-script-utils/src/Plutus/Script/Utils/Address.hs b/plutus-script-utils/src/Plutus/Script/Utils/Address.hs index 546af1a..7d243c3 100644 --- a/plutus-script-utils/src/Plutus/Script/Utils/Address.hs +++ b/plutus-script-utils/src/Plutus/Script/Utils/Address.hs @@ -70,4 +70,4 @@ instance ToMaybeStakingCredential (Maybe Api.StakingCredential) where -- | Similar to 'ToAddress', but for Cardano addresses class ToCardanoAddress a where - toCardanoAddress :: C.Api.NetworkId -> a -> C.Api.AddressInEra C.Api.ConwayEra + toCardanoAddress :: C.Api.NetworkId -> a -> C.Api.AddressInEra C.Api.DijkstraEra From 39aa3ee76a7de0b14aa6498e4d0ed05eab826154 Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 29 Sep 2026 15:34:51 +0200 Subject: [PATCH 8/8] cardano-node-emulator: bump emulator era to Dijkstra Migrate the emulator's canonical era from Conway to Dijkstra: - EmulatorEra = DijkstraEra and all cardano-api era witnesses (ScriptInEra, *EraOnwards, PlutusScriptVxIn*, TxBodyContent) renamed to Dijkstra. - Transition config now supplies the additional DijkstraGenesis (emulatorDijkstraGenesisDefaults) required by mkLatestTransitionConfig. - Validated-tx construction wraps MkDijkstraTx (DijkstraTx ..) instead of AlonzoTx, and reads validity via isValidTxL (the AlonzoTx isValid field accessor no longer applies to the Dijkstra tx newtype). - Ledger predicate failure uses DijkstraLedgerPredFailure (DijkstraUtxowFailure). - GovState for Dijkstra is still ConwayGovState, so the Conway.Governance constitution lenses and ConwayGenesis are retained. Note: the package does not fully build yet due to pre-existing, unrelated new-dependency breakage (freer-extras, optics, PlutusTx Lift API) that is out of scope for the era bump. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- .../cardano-node-emulator.cabal | 1 + cardano-node-emulator/package.yaml | 1 + .../src/Cardano/Node/Emulator/Generators.hs | 14 +++---- .../Node/Emulator/Internal/Node/Params.hs | 13 ++++-- .../Node/Emulator/Internal/Node/Validation.hs | 40 ++++++++++--------- 5 files changed, 39 insertions(+), 30 deletions(-) diff --git a/cardano-node-emulator/cardano-node-emulator.cabal b/cardano-node-emulator/cardano-node-emulator.cabal index dd68c66..26ffb4c 100644 --- a/cardano-node-emulator/cardano-node-emulator.cabal +++ b/cardano-node-emulator/cardano-node-emulator.cabal @@ -49,6 +49,7 @@ library , cardano-ledger-binary , cardano-ledger-conway , cardano-ledger-core + , cardano-ledger-dijkstra , cardano-ledger-shelley , cardano-slotting , containers diff --git a/cardano-node-emulator/package.yaml b/cardano-node-emulator/package.yaml index 13614fc..3441aa5 100644 --- a/cardano-node-emulator/package.yaml +++ b/cardano-node-emulator/package.yaml @@ -58,6 +58,7 @@ library: - cardano-ledger-binary - cardano-ledger-conway - cardano-ledger-core + - cardano-ledger-dijkstra - cardano-ledger-shelley - cardano-slotting - containers diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs index 9c835f5..22f64e3 100644 --- a/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs @@ -218,7 +218,7 @@ genValidTransaction = genValidTransaction' generatorModel genValidTransactionBody :: Mockchain -> - Gen (C.TxBodyContent C.BuildTx C.ConwayEra) + Gen (C.TxBodyContent C.BuildTx C.DijkstraEra) genValidTransactionBody = genValidTransactionBody' generatorModel -- | Generate a valid transaction, using the unspent outputs provided. @@ -246,7 +246,7 @@ genValidTransactionSpending' g ins totalVal = makeTx :: (MonadFail m) => - C.TxBodyContent C.BuildTx C.ConwayEra -> + C.TxBodyContent C.BuildTx C.DijkstraEra -> m CardanoTx makeTx bodyContent = do txBody <- @@ -260,7 +260,7 @@ makeTx bodyContent = do genValidTransactionBody' :: GeneratorModel -> Mockchain -> - Gen (C.TxBodyContent C.BuildTx C.ConwayEra) + Gen (C.TxBodyContent C.BuildTx C.DijkstraEra) genValidTransactionBody' g (Mockchain _ ops _) = do -- Take a random number of UTXO from the input nUtxo <- @@ -276,7 +276,7 @@ genValidTransactionBodySpending' :: GeneratorModel -> [C.TxIn] -> C.Value -> - Gen (C.TxBodyContent C.BuildTx C.ConwayEra) + Gen (C.TxBodyContent C.BuildTx C.DijkstraEra) genValidTransactionBodySpending' g ins totalVal = do mintAmount <- toInteger <$> Gen.int (Range.linear 0 maxBound) mintTokenName <- Gen.genAssetName @@ -308,7 +308,7 @@ genValidTransactionBodySpending' g ins totalVal = do zip outVals pubKeys let mintWitness = C.PlutusScriptWitness - C.PlutusScriptV1InConway + C.PlutusScriptV1InDijkstra C.PlutusScriptV1 (C.PScript $ C.examplePlutusScriptAlwaysSucceeds C.WitCtxMint) C.NoScriptDatumForMint @@ -319,7 +319,7 @@ genValidTransactionBodySpending' g ins totalVal = do then C.TxMintNone else C.TxMintValue - C.MaryEraOnwardsConway + C.MaryEraOnwardsDijkstra $ Map.singleton alwaysSucceedPolicyId (fromList [(mintTokenName, C.Quantity mintAmount)], C.BuildTxWith mintWitness) @@ -327,7 +327,7 @@ genValidTransactionBodySpending' g ins totalVal = do txInsCollateral <- maybe (fail "Cannot gen collateral") - (pure . C.TxInsCollateral C.AlonzoEraOnwardsConway . flip take ins . fromIntegral) + (pure . C.TxInsCollateral C.AlonzoEraOnwardsDijkstra . flip take ins . fromIntegral) (gmMaxCollateralInputs g) pure $ Tx.emptyTxBodyContent diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs index f3afde6..fac2156 100644 --- a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs @@ -27,6 +27,7 @@ module Cardano.Node.Emulator.Internal.Node.Params emulatorShelleyGenesisDefaults, emulatorAlonzoGenesisDefaults, emulatorConwayGenesisDefaults, + emulatorDijkstraGenesisDefaults, keptBlocks, -- * cardano-ledger specific types and conversion functions @@ -47,7 +48,7 @@ import Cardano.Ledger.Api.PParams qualified as C import Cardano.Ledger.Api.Transition qualified as C import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), boundRational, unNonZero) import Cardano.Ledger.Binary.Version (Version, natVersion) -import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Plutus.ExUnits (ExUnits (ExUnits), Prices (Prices)) import Cardano.Ledger.Shelley.API (Coin (Coin), Globals, mkShelleyGlobals) import Cardano.Ledger.Shelley.API qualified as C.Ledger @@ -83,7 +84,7 @@ import PlutusLedgerApi.V1 (POSIXTime (POSIXTime, getPOSIXTime)) import Prettyprinter (Pretty (pretty), viaShow, vsep, (<+>)) -- | The default era for the emulator -type EmulatorEra = ConwayEra +type EmulatorEra = DijkstraEra type PParams = C.PParams EmulatorEra @@ -134,7 +135,7 @@ instance Pretty Params where emulatorPParams :: Params -> PParams emulatorPParams = pEmulatorPParams -ledgerProtocolParameters :: Params -> C.LedgerProtocolParameters C.ConwayEra +ledgerProtocolParameters :: Params -> C.LedgerProtocolParameters C.DijkstraEra ledgerProtocolParameters = C.LedgerProtocolParameters . emulatorPParams -- | Set higher limits on transaction size and execution units. @@ -161,6 +162,7 @@ defaultConfig = emulatorShelleyGenesisDefaults emulatorAlonzoGenesisDefaults emulatorConwayGenesisDefaults + emulatorDijkstraGenesisDefaults emulatorShelleyGenesisDefaults :: C.ShelleyGenesis emulatorShelleyGenesisDefaults = @@ -180,7 +182,7 @@ instance MonadFail (Either String) where emulatorAlonzoGenesisDefaults :: C.AlonzoGenesis emulatorAlonzoGenesisDefaults = - (C.alonzoGenesisDefaults C.ConwayEra) + (C.alonzoGenesisDefaults C.DijkstraEra) { C.agPrices = Prices (fromJust $ boundRational (577 % 10_000)) (fromJust $ boundRational (721 % 10_000_000)), C.agMaxTxExUnits = ExUnits 14_000_000 10_000_000_000 @@ -189,6 +191,9 @@ emulatorAlonzoGenesisDefaults = emulatorConwayGenesisDefaults :: C.ConwayGenesis emulatorConwayGenesisDefaults = C.conwayGenesisDefaults +emulatorDijkstraGenesisDefaults :: C.DijkstraGenesis +emulatorDijkstraGenesisDefaults = C.dijkstraGenesisDefaults + paramsFromConfig :: TransitionConfig -> Params paramsFromConfig tc = Params diff --git a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs index 843c98f..1b5b6ce 100644 --- a/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs +++ b/cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Validation.hs @@ -34,8 +34,9 @@ import Cardano.Ledger.Alonzo.Rules qualified as Alonzo import Cardano.Ledger.Alonzo.Tx qualified as Alonzo import Cardano.Ledger.Coin qualified as Cardano import Cardano.Ledger.Conway.Governance qualified as Conway -import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (ConwayUtxowFailure)) import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Dijkstra.Rules (DijkstraLedgerPredFailure (DijkstraUtxowFailure)) +import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (DijkstraTx), pattern MkDijkstraTx) import Cardano.Ledger.Credential qualified as Cardano import Cardano.Ledger.Plutus.Evaluate qualified as Ledger import Cardano.Ledger.Shelley.API qualified as Shelley @@ -87,7 +88,7 @@ There are also some limitations of the emulator's functionality that could be addressed by extending the emulator, without having to bring in the full block validating machinery. -\* We cannot represent different eras - everything is 'ConwayEra'. +\* We cannot represent different eras - everything is 'DijkstraEra'. \* There is no handling of epoch boundaries, rewards, etc. \* The block size is unlimited - we simply take all transactions from the mempool when we make a block. There is however a limit on the size of @@ -237,15 +238,15 @@ updateStateParams params (EmulatedLedgerState ledgerEnv ledgerState) = applyTx :: Params -> EmulatedLedgerState -> - Ledger.Tx EmulatorEra -> - Either (Shelley.ApplyTxError EmulatorEra) (EmulatedLedgerState, Shelley.Validated (Ledger.Tx EmulatorEra)) + Ledger.Tx Ledger.TopTx EmulatorEra -> + Either (Shelley.ApplyTxError EmulatorEra) (EmulatedLedgerState, Shelley.Validated (Ledger.Tx Ledger.TopTx EmulatorEra)) applyTx params (EmulatedLedgerState ledgerEnv ledgerState) tx = first (EmulatedLedgerState ledgerEnv) <$> Shelley.applyTx (emulatorGlobals params) ledgerEnv ledgerState tx hasValidationErrors :: Params -> EmulatedLedgerState -> - C.Api.Tx C.Api.ConwayEra -> + C.Api.Tx C.Api.DijkstraEra -> (EmulatedLedgerState, P.Ledger.ValidationResult) hasValidationErrors params ls tx = case validateAndApplyTx params ls tx of @@ -266,7 +267,7 @@ hasValidationErrors params ls tx = -- To handle the execution units failures, we inspect the validated -- transaction and check if we get a @IsValid False@. Right _ - | Alonzo.IsValid False <- Alonzo.isValid $ Shelley.extractTx $ P.Ledger.getOnChainTx vtx -> + | Alonzo.IsValid False <- Shelley.extractTx (P.Ledger.getOnChainTx vtx) ^. Alonzo.isValidTxL -> ( ls', P.Ledger.FailPhase2 vtx @@ -278,10 +279,10 @@ hasValidationErrors params ls tx = validateAndApplyTx :: Params -> EmulatedLedgerState -> - C.Api.Tx C.Api.ConwayEra -> + C.Api.Tx C.Api.DijkstraEra -> Either (Shelley.ApplyTxError EmulatorEra) - (EmulatedLedgerState, Shelley.Validated (Ledger.Tx EmulatorEra)) + (EmulatedLedgerState, Shelley.Validated (Ledger.Tx Ledger.TopTx EmulatorEra)) validateAndApplyTx params ledgerState (C.Api.ShelleyTx _ tx) = constructValidated (emulatorGlobals params) @@ -309,14 +310,14 @@ constructValidated :: Shelley.Globals -> Shelley.UtxoEnv EmulatorEra -> Shelley.UTxOState EmulatorEra -> - Ledger.Tx EmulatorEra -> - m (Alonzo.AlonzoTx EmulatorEra) + Ledger.Tx Ledger.TopTx EmulatorEra -> + m (Ledger.Tx Ledger.TopTx EmulatorEra) constructValidated globals (Shelley.UtxoEnv _ pp _) st tx = case Alonzo.collectPlutusScriptsWithContext ei sysS pp tx utxo of Left errs -> throwError ( Shelley.ApplyTxError - ( ConwayUtxowFailure + ( DijkstraUtxowFailure (Ledger.injectFailure (Alonzo.UtxosFailure (Ledger.injectFailure $ Alonzo.CollectErrors errs))) :| [] ) @@ -324,11 +325,12 @@ constructValidated globals (Shelley.UtxoEnv _ pp _) st tx = Right sLst -> let scriptEvalResult = Alonzo.evalPlutusScripts sLst vTx = - Alonzo.AlonzoTx - (view Ledger.bodyTxL tx) - (view Ledger.witsTxL tx) - (Alonzo.IsValid (lift scriptEvalResult)) - (view Ledger.auxDataTxL tx) + MkDijkstraTx $ + DijkstraTx + (view Ledger.bodyTxL tx) + (view Ledger.witsTxL tx) + (Alonzo.IsValid (lift scriptEvalResult)) + (view Ledger.auxDataTxL tx) in pure vTx where utxo = Shelley.utxosUtxo st @@ -340,7 +342,7 @@ constructValidated globals (Shelley.UtxoEnv _ pp _) st tx = unsafeMakeValid :: P.Ledger.CardanoTx -> P.Ledger.OnChainTx unsafeMakeValid (P.Ledger.CardanoEmulatorEraTx (C.Api.Tx txBody _)) = let C.Api.ShelleyTxBody _ txBody' _ _ _ _ = txBody - vtx :: Ledger.Tx EmulatorEra = Alonzo.AlonzoTx txBody' mempty (Alonzo.IsValid True) Shelley.SNothing + vtx :: Ledger.Tx Ledger.TopTx EmulatorEra = MkDijkstraTx (DijkstraTx txBody' mempty (Alonzo.IsValid True) Shelley.SNothing) in P.Ledger.OnChainTx $ Shelley.unsafeMakeValidated vtx validateCardanoTx :: @@ -356,7 +358,7 @@ validateCardanoTx params ls ctx@(P.Ledger.CardanoEmulatorEraTx tx) = getTxExUnitsWithLogs :: Params -> Shelley.UTxO EmulatorEra -> - C.Api.Tx C.Api.ConwayEra -> + C.Api.Tx C.Api.DijkstraEra -> Either P.Ledger.ValidationErrorInPhase P.Ledger.RedeemerReport getTxExUnitsWithLogs params utxo (C.Api.ShelleyTx _ tx) = traverse (either toCardanoLedgerError Right) result @@ -370,7 +372,7 @@ getTxExUnitsWithLogs params utxo (C.Api.ShelleyTx _ tx) = createTransactionBody :: Params -> P.Ledger.CardanoBuildTx -> - Either P.Ledger.ToCardanoError (C.Api.TxBody C.Api.ConwayEra) + Either P.Ledger.ToCardanoError (C.Api.TxBody C.Api.DijkstraEra) createTransactionBody params (P.Ledger.CardanoBuildTx bodyContent) = first (P.Ledger.TxBodyError . C.Api.displayError) $ C.Api.createTransactionBody C.Api.shelleyBasedEra $