From 24af42db71d6020069fdc42afd41020180eff432 Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Sat, 27 Apr 2024 17:49:47 +0700 Subject: [PATCH 1/4] Fixup CI working --- .envrc | 2 +- .github/workflows/haskell-ci.yml | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.envrc b/.envrc index d66daa8..37d02de 100644 --- a/.envrc +++ b/.envrc @@ -3,4 +3,4 @@ if ! has nix_direnv_version || ! nix_direnv_version 2.3.0; then source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/2.3.0/direnvrc" "sha256-Dmd+j63L84wuzgyjITIfSxSD57Tx7v51DMxVZOsiUD8=" fi # https://github.com/input-output-hk/devx Slightly opinionated shared GitHub Action for Cardano-Haskell projects -use flake "github:input-output-hk/devx#ghc963-iog" +use flake "github:input-output-hk/devx#ghc964-iog" diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 90692bc..d9492d4 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ name: Haskell-CI on: - - push + - pull_request jobs: tests: runs-on: ubuntu-latest @@ -31,8 +31,8 @@ jobs: ~/.cabal/packages ~/.cabal/store dist-newstyle - key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} - restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- + key: ${{ runner.os }}-ghc964-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} + restore-keys: ${{ runner.os }}-ghc964- - name: Cabal build and test shell: devx {0} run: | @@ -44,5 +44,5 @@ jobs: run: | cabal install cabal-fmt cabal install fourmolu - cabal-fmt --check cem-script.cabal - fourmolu . + /home/runner/.cabal-devx/bin/cabal-fmt --check cem-script.cabal + /home/runner/.cabal-devx/bin/fourmolu . From 2d3c80ded3f9df740529dd60f961557ad6d199cf Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Sun, 28 Apr 2024 17:33:17 +0700 Subject: [PATCH 2/4] Better CI caching --- .github/workflows/haskell-ci.yml | 36 +++++++++++++++++++------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index d9492d4..ba242ce 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,16 +1,12 @@ name: Haskell-CI on: - pull_request + - merge_group jobs: tests: runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - - name: Cache DevX - uses: actions/cache@v3 - with: - path: /nix - key: "devx-ghc96" - name: Setup DevX uses: input-output-hk/actions/devx@latest with: @@ -24,15 +20,11 @@ jobs: echo 'Running in DevX' ghc --version cabal --version - - name: Cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle - uses: actions/cache@v3 + - name: Save DevX cache + uses: actions/cache/save@v3 with: - path: | - ~/.cabal/packages - ~/.cabal/store - dist-newstyle - key: ${{ runner.os }}-ghc964-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} - restore-keys: ${{ runner.os }}-ghc964- + path: /nix/store + key: "devx-ghc96" - name: Cabal build and test shell: devx {0} run: | @@ -45,4 +37,20 @@ jobs: cabal install cabal-fmt cabal install fourmolu /home/runner/.cabal-devx/bin/cabal-fmt --check cem-script.cabal - /home/runner/.cabal-devx/bin/fourmolu . + /home/runner/.cabal-devx/bin/fourmolu --mode check . + - name: Save cabal cache + uses: actions/cache/save@v3 + if: always() + with: + path: | + ~/.cabal-devx + dist-newstyle + key: ${{ runner.os }}-ghc964-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} + - name: Save cabal cache (generic key) + uses: actions/cache/save@v3 + if: always() + with: + path: | + ~/.cabal-devx + dist-newstyle + key: ${{ runner.os }}-ghc964- From e13c2fbf854fec8096eafbbe67527a86be6b4212 Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Sun, 28 Apr 2024 20:16:01 +0700 Subject: [PATCH 3/4] Fixup .cabal linting --- cem-script.cabal | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/cem-script.cabal b/cem-script.cabal index b02dd81..da1930e 100644 --- a/cem-script.cabal +++ b/cem-script.cabal @@ -19,12 +19,10 @@ common common-lang -- Options from MLabs styleguide ghc-options: - - -- -Wall - -- -Wcompat -Wincomplete-record-updates - -- -Wincomplete-uni-patterns -Wredundant-constraints - -- -Wmissing-export-lists -Wmissing-deriving-strategies - -- -Wno-redundant-constraints + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wmissing-export-lists -Wmissing-deriving-strategies + -Wno-redundant-constraints if !flag(dev) ghc-options: -Werror @@ -112,7 +110,8 @@ common common-offchain build-depends: , aeson , bytestring - , cardano-api:{cardano-api, internal} == 8.38.0.0 + , cardano-api ==8.38.0.0 + , cardano-api:internal , cardano-crypto-class , cardano-ledger-alonzo , cardano-ledger-babbage @@ -174,7 +173,8 @@ library other-modules: Cardano.CEM.Monads.L1Commons build-depends: - , cem-script:{cardano-extras, data-spine} + , cem-script:cardano-extras + , cem-script:data-spine , clb , dependent-map , ouroboros-consensus @@ -187,7 +187,9 @@ test-suite cem-sdk-test type: exitcode-stdio-1.0 build-depends: - , cem-script:{cem-script, cardano-extras, data-spine} + , cem-script + , cem-script:cardano-extras + , cem-script:data-spine , clb , dependent-map , hspec From 3d2f6ab00edf778eda539c7d96969f2a318353e9 Mon Sep 17 00:00:00 2001 From: Gregory Gerasev Date: Mon, 29 Apr 2024 01:18:55 +0700 Subject: [PATCH 4/4] Fixup: fourmolu linting and removing wrong files --- src-lib/cardano-extras/Plutus/Deriving.hs | 144 ------------------ src/Cardano/CEM/Constraints.hs | 74 --------- src/Cardano/CEM/Documentation.hs | 18 +-- src/Cardano/CEM/Examples/Escrow.hs | 173 ---------------------- 4 files changed, 9 insertions(+), 400 deletions(-) delete mode 100644 src-lib/cardano-extras/Plutus/Deriving.hs delete mode 100644 src/Cardano/CEM/Constraints.hs delete mode 100644 src/Cardano/CEM/Examples/Escrow.hs diff --git a/src-lib/cardano-extras/Plutus/Deriving.hs b/src-lib/cardano-extras/Plutus/Deriving.hs deleted file mode 100644 index c97caab..0000000 --- a/src-lib/cardano-extras/Plutus/Deriving.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -{- | - Module: PlutusTx.Deriving - Copyright: (C) MLabs 2021 - License: Apache 2.0 - Maintainer: Koz Ross - Portability: GHC only - Stability: Experimental - - Taken from here temporarily: - https://github.com/Liqwid-Labs/plutus-extra/blob/master/ - plutus-deriving/src/PlutusTx/Deriving.hs --} -module Plutus.Deriving (deriveEq) where - -import Prelude - -import Control.Monad (replicateM) -import Language.Haskell.TH ( - Body (NormalB), - Clause (Clause), - Con ( - ForallC, - GadtC, - InfixC, - NormalC, - RecC, - RecGadtC - ), - Dec ( - DataD, - FunD, - InstanceD, - NewtypeD, - PragmaD - ), - Exp (ConE, UInfixE, VarE), - Info (TyConI), - Inline (Inlinable), - Name, - Pat (ConP, VarP, WildP), - Phases (AllPhases), - Pragma (InlineP), - Q, - RuleMatch (FunLike), - TyVarBndr (KindedTV, PlainTV), - Type (AppT, ConT, VarT), - nameBase, - newName, - reify, - ) -import PlutusTx.Prelude qualified as PTx - -{- | Generates a lawful 'PTx.Eq' instance for the type named by the input. This - instance will obey the following laws: - - * Reflexivity (for any @x@, @x == x = True@) - * Symmetry (for any @x, y@, @x == y = y PTx.== x@) - * Transitivity (for any @x, y, z@, if @x == y@ and @y == z@, then @x == z@) - * Substitution (for any @x, y@ and pure @f@, @x == y@ implies @f x == f y@) - - @since 1.0 --} -deriveEq :: Name -> Q [Dec] -deriveEq name = do - info <- reify name - case info of - TyConI (DataD _ name' tyVars _ constructors _) -> - mkEq name' tyVars constructors - TyConI (NewtypeD _ name' tyVars _ constructor _) -> - mkEq name' tyVars [constructor] - _ -> error $ nameBase name <> " is not a data or newtype-defined type." - --- Helpers - -mkEq :: Name -> [TyVarBndr _] -> [Con] -> Q [Dec] -mkEq name tyVars constructors = do - let namePreds = mkCtxVar <$> tyVars - let instanceType = mkInstanceType name (fst <$> namePreds) - method <- mkEqMethod constructors - pure [InstanceD Nothing (snd <$> namePreds) instanceType method] - -mkCtxVar :: TyVarBndr _ -> (Name, Type) -mkCtxVar = \case - PlainTV name -> (name, go name) - KindedTV name _ -> (name, go name) - where - go :: Name -> Type - go = AppT (ConT ''PTx.Eq) . VarT - -mkInstanceType :: Name -> [Name] -> Type -mkInstanceType typeName = AppT (ConT ''PTx.Eq) . foldr go (ConT typeName) - where - go :: Name -> Type -> Type - go varName acc = AppT acc (VarT varName) - -mkEqMethod :: [Con] -> Q [Dec] -mkEqMethod constructors = do - let methodInlineable = PragmaD . InlineP '(PTx.==) Inlinable FunLike $ AllPhases - funDef <- - FunD '(PTx.==) <$> case constructors of - [] -> error "Cannot generate Eq for a type with no constructors." - _ -> do - activeClauses <- traverse mkConstructorMatch constructors - let catchAllClause = - Clause - [WildP, WildP] - (NormalB . ConE $ 'PTx.False) - [] - pure $ activeClauses <> [catchAllClause] - pure [methodInlineable, funDef] - -mkConstructorMatch :: Con -> Q Clause -mkConstructorMatch = \case - NormalC name vars -> go name . length $ vars - RecC name vars -> go name . length $ vars - InfixC {} -> - error "Cannot generate Eq for types with infix constructors." - ForallC {} -> - error "Cannot generate Eq for types with existentials." - GadtC {} -> - error "Cannot generate Eq for GADTs." - RecGadtC {} -> - error "Cannot generate Eq for GADTs." - where - go :: Name -> Int -> Q Clause - go name count = do - namesLeft <- replicateM count (newName "x") - namesRight <- replicateM count (newName "y") - let leftPat = ConP name . fmap VarP $ namesLeft - let rightPat = ConP name . fmap VarP $ namesRight - let bod = NormalB $ case zip namesLeft namesRight of - [] -> ConE 'PTx.True - (lName, rName) : names -> - foldr - andEq - (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) - names - pure . Clause [leftPat, rightPat] bod $ [] - -andEq :: (Name, Name) -> Exp -> Exp -andEq (lName, rName) = - UInfixE (UInfixE (VarE lName) (VarE '(PTx.==)) (VarE rName)) (VarE '(PTx.&&)) diff --git a/src/Cardano/CEM/Constraints.hs b/src/Cardano/CEM/Constraints.hs deleted file mode 100644 index 4b5c6d1..0000000 --- a/src/Cardano/CEM/Constraints.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Cardano.CEM.Constraints where - -import Prelude - - -import PlutusTx.IsData (toData) -import PlutusTx.Prelude -import Prelude (Show) -import Prelude qualified - -import Data.Data (Proxy) -import Data.Map qualified as Map - -import PlutusLedgerApi.V1.Address (Address, pubKeyHashAddress) -import PlutusLedgerApi.V1.Crypto (PubKeyHash) -import PlutusLedgerApi.V2 ( - BuiltinData (..), - Data (..), - FromData (..), - ToData (..), - Value, - fromData, - ) -import PlutusTx.Show.TH (deriveShow) - -import Cardano.CEM.Stages ( Stages(..) ) - - --- | This is different ways to specify address -data AddressSpec - = ByAddress Address - | ByPubKey PubKeyHash - | ByScript -- TODO - | BySameScript - deriving stock (Show, Prelude.Eq) - -{-# INLINEABLE addressSpecToAddress #-} -addressSpecToAddress :: Address -> AddressSpec -> Address -addressSpecToAddress ownAddress addressSpec = case addressSpec of - ByAddress address -> address - ByPubKey pubKey -> pubKeyHashAddress pubKey - BySameScript -> ownAddress - -data TxFanFilter script = MkTxFanFilter - { address :: AddressSpec - , rest :: TxFanFilter' script - } - deriving stock (Show, Prelude.Eq) - -data TxFanFilter' script - = Anything - | -- TODO - BySameCEM BuiltinData - | ByDatum BuiltinData - deriving stock (Show, Prelude.Eq) - --- TODO: use natural numbers -data Quantor = Exist Integer | SumValueEq Value - deriving stock (Show) - -data TxFanKind = In | InRef | Out - deriving stock (Prelude.Eq, Prelude.Show) - -data TxFanConstraint script = MkTxFanC - { txFanCKind :: TxFanKind - , txFanCFilter :: TxFanFilter script - , txFanCQuantor :: Quantor - } - deriving (Show) - --- TH deriving done at end of file for GHC staging reasons - -deriveShow ''TxFanKind -deriveShow ''TxFanFilter' diff --git a/src/Cardano/CEM/Documentation.hs b/src/Cardano/CEM/Documentation.hs index 920ec00..f9a7faf 100644 --- a/src/Cardano/CEM/Documentation.hs +++ b/src/Cardano/CEM/Documentation.hs @@ -2,9 +2,9 @@ module Cardano.CEM.Documentation (cemDotGraphString) where import Prelude +import Data.Foldable (fold) import Data.Map qualified as Map import Data.Proxy -import Data.Foldable (fold) import Cardano.CEM @@ -31,14 +31,14 @@ cemDotGraphString name proxy = edges = fold $ [ maybe "\"Void In\"" showSpine from - <> " -> " - <> maybe "\"Void Out\"" showSpine to - <> " [label=\"" - <> showSpine transition - <> " (stage " - <> show stage - <> ")" - <> "\"]; \n" + <> " -> " + <> maybe "\"Void Out\"" showSpine to + <> " [label=\"" + <> showSpine transition + <> " (stage " + <> show stage + <> ")" + <> "\"]; \n" | (transition, (stage, from, to)) <- Map.assocs $ transitionStage proxy ] diff --git a/src/Cardano/CEM/Examples/Escrow.hs b/src/Cardano/CEM/Examples/Escrow.hs deleted file mode 100644 index 35ca781..0000000 --- a/src/Cardano/CEM/Examples/Escrow.hs +++ /dev/null @@ -1,173 +0,0 @@ -module Cardano.CEM.Examples.Escrow where - -import PlutusTx qualified -import PlutusTx.Prelude - -import PlutusLedgerApi.V1 (Address, Value) -import PlutusLedgerApi.V1.Crypto (PubKeyHash) - -import Cardano.CEM -import Cardano.CEM.Stages -import Cardano.CEM.OnChain (CEMScriptIsData, IsData) -import PlutusLedgerApi.V1.Value (AssetClass, assetClassValue) -import PlutusTx.IsData (FromData, ToData) -import qualified PlutusTx as Plutus - --- Generic escrows - --- TODO: move to Commons -class Escrow escrow where - data EscrowParams escrow - data EscrowUnlock escrow - unlockConstraints :: - EscrowParams escrow -> - EscrowUnlock escrow -> - Either BuiltinString (TransitionSpec (EscrowScript escrow)) - -newtype EscrowScript escrow = MkEscrowScript escrow - -instance - (Escrow escrow, IsData (EscrowUnlock escrow)) => - CEMScript (EscrowScript escrow) - where - type Stage (EscrowScript escrow) = SingleStage - data Params (EscrowScript escrow) = MkEscrowParams (EscrowParams escrow) - data State (EscrowScript escrow) = Locked - data Transition (EscrowScript escrow) = UnLock (EscrowUnlock escrow) - - transitionSpec (MkEscrowParams params) (Just Locked) (UnLock unlock) = - unlockConstraints params unlock - - --- TODO -instance FromData (EscrowParams escrow) => FromData (Params (EscrowScript escrow)) where -instance ToData (EscrowParams escrow) => ToData (Params (EscrowScript escrow)) where -Plutus.unstableMakeIsData 'Locked --- Plutus.unstableMakeIsData 'UnLock - --- Specific escrows - -data UnboundedEscrow - -instance Escrow UnboundedEscrow where - data EscrowParams UnboundedEscrow = MkUnboundedEscrowParams - data EscrowUnlock UnboundedEscrow = UnboundedEscrowUnlock - unlockConstraints _ _ = - Right $ - MkTransitionSpec - { constraints = [] - , signers = [] - , stage = Always - } - -data UserLockedEscrow - -instance Escrow UserLockedEscrow where - data EscrowParams UserLockedEscrow = MkUserLockedState - { unlockingUser :: PubKeyHash - } - data EscrowUnlock UserLockedEscrow = MkUserUnlock - unlockConstraints state _ = - Right $ - MkTransitionSpec - { constraints = [] - , signers = [unlockingUser state] - , stage = Always - } - -PlutusTx.unstableMakeIsData 'MkUserLockedState -PlutusTx.unstableMakeIsData 'MkUserUnlock - -data TokenLockedEscrow - -instance Escrow TokenLockedEscrow where - data EscrowParams TokenLockedEscrow = MkTokenLockedState - { unlockingToken :: AssetClass - } - data EscrowUnlock TokenLockedEscrow = MkTokenUnlock - { unlocker :: PubKeyHash - } - unlockConstraints params (MkTokenUnlock {unlocker}) = - Right $ - MkTransitionSpec - { constraints = - [ MkTxFanC - InRef - (MkTxFanFilter (ByPubKey unlocker) Anything) - (SumValueEq singleToken) - -- TODO: unlocker? - ] - , signers = [unlocker] - , stage = Always - } - where - singleToken = assetClassValue (unlockingToken params) 1 - -data HashLockedEscrow - -instance Escrow HashLockedEscrow where - data EscrowParams HashLockedEscrow = MkHashLockedState - { secretHash :: BuiltinByteString - } - data EscrowUnlock HashLockedEscrow = MkHashLockedUnlock - { secretValue :: BuiltinByteString - } - unlockConstraints state unlock = - if blake2b_256 (secretValue unlock) == secretHash state - then - Right $ - MkTransitionSpec - { constraints = [] - , signers = [] - , stage = Always - } - else Left "Wrong hash" - -data FixedSwapEscrow - -instance Escrow FixedSwapEscrow where - data EscrowParams FixedSwapEscrow = MkSwapState - { creator :: Address - , lockedValue :: Value - , toSwapValue :: Value - } - data EscrowUnlock FixedSwapEscrow = FixedSwapUnlock - { swappingActor :: Address - } - unlockConstraints state unlock = - Right $ - MkTransitionSpec - { constraints = - [ -- TODO: balance, need to sign? - MkTxFanC Out (MkTxFanFilter (ByAddress (creator state)) Anything) (SumValueEq (toSwapValue state)) - , MkTxFanC Out (MkTxFanFilter (ByAddress (swappingActor unlock)) Anything) (SumValueEq (lockedValue state)) - ] - , signers = [] - , stage = Always - } - -data FeeDistributionEscrow - -instance Escrow FeeDistributionEscrow where - data EscrowParams FeeDistributionEscrow = MkFeeDistributionParams - { feeReceivers :: [Address] - } - - -- TODO: explain - data EscrowUnlock FeeDistributionEscrow = MkFeeDistributionUnlock - { amountPerFeeReceiver :: Value - } - - unlockConstraints params unlock = - Right $ - MkTransitionSpec - { constraints = map receiverConstraint $ feeReceivers params - , signers = [] - , stage = Always - } - where - receiverConstraint address = - MkTxFanC - Out - (MkTxFanFilter (ByAddress address) Anything) - (SumValueEq $ amountPerFeeReceiver unlock)