Merge branch 'master' into emiflake/stake

.github/format.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
 # Extensions necessary to tell fourmolu about
-EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -fplugin=RecordDotPreprocessor"
+EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot"
 SOURCES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs')
-nix run nixpkgs#haskellPackages.fourmolu -- --mode check --check-idempotence $EXTENSIONS $SOURCES
+nix run nixpkgs#haskell.packages.ghc921.fourmolu -- --mode check --check-idempotence $EXTENSIONS $SOURCES

Makefile

@@ -13,7 +13,7 @@ HOOGLE_PORT=8081
 hoogle:
 	hoogle server --local --port $(HOOGLE_PORT) > /dev/null &
 
-FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -fplugin=RecordDotPreprocessor
+FORMAT_EXTENSIONS := -o -XQuasiQuotes -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XOverloadedRecordDot
 format:
 	find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m inplace
 	git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' | xargs nixfmt

agora.cabal

@@ -9,100 +9,129 @@ license:            Apache-2.0
 -- Common Stanza Declarations
 
 -- Language options, warnings, some options for plutus
+
 common lang
-  default-language:   Haskell2010
+  ghc-options:
+    -Wall -Wcompat -Wincomplete-uni-patterns -Wno-unused-do-bind
+    -Wno-partial-type-signatures -Wmissing-export-lists
+    -Wincomplete-record-updates -Wmissing-deriving-strategies
+    -Wno-name-shadowing -Wunused-foralls -fprint-explicit-foralls
+    -fprint-explicit-kinds -Werror
+
+  mixins:
+    base hiding (Prelude),
+    pprelude (PPrelude as Prelude)
+
   default-extensions:
-    NoImplicitPrelude
+    NoStarIsType
     BangPatterns
     BinaryLiterals
+    ConstrainedClassMethods
     ConstraintKinds
     DataKinds
     DeriveAnyClass
+    DeriveDataTypeable
+    DeriveFoldable
     DeriveFunctor
     DeriveGeneric
+    DeriveLift
     DeriveTraversable
     DerivingStrategies
     DerivingVia
-    DuplicateRecordFields
+    DoAndIfThenElse
     EmptyCase
+    EmptyDataDecls
+    EmptyDataDeriving
+    ExistentialQuantification
+    ExplicitForAll
     FlexibleContexts
     FlexibleInstances
-    GADTs
+    ForeignFunctionInterface
-    GeneralizedNewtypeDeriving
+    GADTSyntax
+    GeneralisedNewtypeDeriving
     HexFloatLiterals
+    ImplicitPrelude
     ImportQualifiedPost
     InstanceSigs
     KindSignatures
     LambdaCase
+    MonomorphismRestriction
     MultiParamTypeClasses
+    NamedFieldPuns
+    NamedWildCards
     NumericUnderscores
     OverloadedStrings
-    QuasiQuotes
+    PartialTypeSignatures
+    PatternGuards
+    PolyKinds
+    PostfixOperators
+    RankNTypes
+    RelaxedPolyRec
     ScopedTypeVariables
     StandaloneDeriving
+    StandaloneKindSignatures
     TupleSections
     TypeApplications
     TypeFamilies
     TypeOperators
     TypeSynonymInstances
-    UndecidableInstances
+    ViewPatterns
+    OverloadedRecordDot
+    QualifiedDo
 
-  ghc-options:
+  default-language:   Haskell2010
-    -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints
-    -Wmissing-export-lists -Werror -Wincomplete-record-updates
-    -fno-ignore-interface-pragmas -fno-omit-interface-pragmas
-    -fobject-code -fno-strictness -fplugin=RecordDotPreprocessor
-    -fplugin-opt PlutusTx.Plugin:dump-uplc
 
 common deps
   build-depends:
     , aeson
     , ansi-terminal
-    , base                     >=4.9 && <5
+    , base                >=4.14 && <5
     , base-compat
     , bytestring
-    , cardano-api
     , cardano-prelude
     , containers
     , data-default
     , data-default-class
+    , generics-sop
     , plutarch
     , plutus-core
-    , plutus-extra
-    , plutus-ledger
     , plutus-ledger-api
     , plutus-tx
+    , pprelude
     , prettyprinter
-    , record-dot-preprocessor
-    , record-hasfield
     , recursion-schemes
     , serialise
     , template-haskell
     , text
-    , generics-sop
 
 common test-deps
   build-depends:
     , QuickCheck
     , quickcheck-instances
-    , tagged
     , tasty
-    , tasty-hunit
+    , tasty-quickcheck
-    , utf8-string
-
---------------------------------------------------------------------------------
 
 library
   import:          lang, deps
   exposed-modules:
     Agora.AuthorityToken
-    Agora.Stake
-    Agora.Voting
     Agora.SafeMoney
     Agora.SafeMoney.QQ
+    Agora.Stake
+    Agora.Voting
+
   other-modules:
   hs-source-dirs:  src
 
+library pprelude
+  build-depends:
+    , base
+    , plutarch
+
+  exposed-modules:  PPrelude
+  hs-source-dirs:   src
+  default-language: Haskell2010
+
 test-suite agora-test
   import:         lang, deps, test-deps
   type:           exitcode-stdio-1.0

cabal.project

@@ -1,42 +1,3 @@
-index-state: 2021-10-20T00:00:00Z
-
 packages: ./.
 
--- Always build tests and benchmarks.
 tests: true
-benchmarks: true
-
--- The only sensible test display option
-test-show-details: direct
-
-allow-newer:
-           -- Pins to an old version of Template Haskell, unclear if/when it will be updated
-           size-based:template-haskell
-           , ouroboros-consensus-byron:formatting
-           , beam-core:aeson
-           , beam-sqlite:aeson
-           , beam-sqlite:dlist
-           , beam-migrate:aeson
-
-constraints:
-  -- big breaking change here, inline-r doens't have an upper bound
-  singletons < 3.0
-  -- bizarre issue: in earlier versions they define their own 'GEq', in newer
-  -- ones they reuse the one from 'some', but there isn't e.g. a proper version
-  -- constraint from dependent-sum-template (which is the library we actually use).
-  , dependent-sum > 0.6.2.0
-  -- Newer Hashable have instances for Set, which breaks beam-migrate
-  -- which declares its own instances of Hashable Set
-  , hashable < 1.3.4.0
-
-package cardano-ledger-alonzo
-  optimization: False
-package ouroboros-consensus-shelley
-  optimization: False
-package ouroboros-consensus-cardano
-  optimization: False
-package cardano-api
-  optimization: False
-
-package plutarch
-  flags: +development

flake.nix

@@ -1,89 +1,18 @@
 {
   description = "agora";
 
-  inputs.haskell-nix.url =
+  inputs.nixpkgs.follows = "plutarch/nixpkgs";
-    "github:input-output-hk/haskell.nix?rev=4aeeba8d713d0b98c92c8c717df24da17d463c1d";
+  inputs.haskell-nix.follows = "plutarch/haskell-nix";
-  inputs.nixpkgs.follows = "haskell-nix/nixpkgs-unstable";
-  inputs.haskell-nix.inputs.nixpkgs.follows = "haskell-nix/nixpkgs-unstable";
 
-  # Temp workaround for Nix issue.
+  # temporary fix for nix versions that have the transitive follows bug
-  inputs.nixpkgs-2111.url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin";
+  # see https://github.com/NixOS/nix/issues/6013
+  inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
 
-  inputs.plutus.url =
+  inputs.plutarch.url = "github:Plutonomicon/plutarch";
-    "github:input-output-hk/plutus?rev=65bad0fd53e432974c3c203b1b1999161b6c2dce";
+  inputs.plutarch.inputs.nixpkgs.follows =
+    "plutarch/haskell-nix/nixpkgs-unstable";
 
-  inputs.plutarch.url =
+  outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }:
-    "github:Plutonomicon/plutarch?rev=a0cbe99921aad7c5df9239cb0240933e4d9b2eaa";
-
-  inputs.goblins.url =
-    "github:input-output-hk/goblins?rev=cde90a2b27f79187ca8310b6549331e59595e7ba";
-  inputs.goblins.flake = false;
-
-  inputs.plutus-extra.url =
-    "github:Liqwid-Labs/plutus-extra?rev=bfeb0d2bb1bc18f147e58c200db2022f5c75eb60";
-  inputs.plutus-extra.flake = false; # Could we set this to true?
-
-  inputs.cardano-node.url =
-    "github:input-output-hk/cardano-node?rev=b6ca519f97a0e795611a63174687e6bb70c9f752";
-  inputs.cardano-node.flake = false;
-
-  inputs.cardano-wallet.url =
-    "github:j-mueller/cardano-wallet?rev=760140e238a5fbca61d1b286d7a80ece058dc729";
-  inputs.cardano-wallet.flake = false;
-
-  inputs.purescript-bridge.url =
-    "github:input-output-hk/purescript-bridge?rev=366fc70b341e2633f3ad0158a577d52e1cd2b138";
-  inputs.purescript-bridge.flake = false;
-
-  inputs.servant-purescript.url =
-    "github:input-output-hk/servant-purescript?rev=ebea59c7bdfc0338d83fca772b9a57e28560bcde";
-  inputs.servant-purescript.flake = false;
-
-  inputs.plutus-apps.url =
-    "github:input-output-hk/plutus-apps?rev=34fe6eeff441166fee0cd0ceba68c1439f0e93d2";
-  inputs.plutus-apps.flake = false;
-
-  inputs.cardano-addresses.url =
-    "github:input-output-hk/cardano-addresses?rev=d2f86caa085402a953920c6714a0de6a50b655ec";
-  inputs.cardano-addresses.flake = false;
-
-  inputs.optparse-applicative.url =
-    "github:input-output-hk/optparse-applicative?rev=7497a29cb998721a9068d5725d49461f2bba0e7a";
-  inputs.optparse-applicative.flake = false;
-
-  inputs.ouroboros-network.url =
-    "github:input-output-hk/ouroboros-network?rev=d613de3d872ec8b4a5da0c98afb443f322dc4dab";
-  inputs.ouroboros-network.flake = false;
-
-  inputs.cardano-ledger-specs.url =
-    "github:input-output-hk/cardano-ledger-specs?rev=bf008ce028751cae9fb0b53c3bef20f07c06e333";
-  inputs.cardano-ledger-specs.flake = false;
-
-  inputs.iohk-monitoring-framework.url =
-    "github:input-output-hk/iohk-monitoring-framework?rev=46f994e216a1f8b36fe4669b47b2a7011b0e153c";
-  inputs.iohk-monitoring-framework.flake = false;
-
-  inputs.cardano-prelude.url =
-    "github:input-output-hk/cardano-prelude?rev=fd773f7a58412131512b9f694ab95653ac430852";
-  inputs.cardano-prelude.flake = false;
-
-  inputs.cardano-base.url =
-    "github:input-output-hk/cardano-base?rev=654f5b7c76f7cc57900b4ddc664a82fc3b925fb0";
-  inputs.cardano-base.flake = false;
-
-  inputs.cardano-crypto.url =
-    "github:input-output-hk/cardano-crypto?rev=f73079303f663e028288f9f4a9e08bcca39a923e";
-  inputs.cardano-crypto.flake = false;
-
-  inputs.flat.url =
-    "github:Quid2/flat?rev=d32c2c0c0c3c38c41177684ade9febe92d279b06";
-  inputs.flat.flake = false;
-
-  inputs.Win32-network.url =
-    "github:input-output-hk/Win32-network?rev=3825d3abf75f83f406c1f7161883c438dac7277d";
-  inputs.Win32-network.flake = false;
-
-  outputs = inputs@{ self, nixpkgs, haskell-nix, plutus, ... }:
     let
       supportedSystems = with nixpkgs.lib.systems.supported;
         tier1 ++ tier2 ++ tier3;
@@ -96,254 +25,88 @@
           overlays = [ haskell-nix.overlay ];
           inherit (haskell-nix) config;
         };
+      nixpkgsFor' = system:
+        import nixpkgs {
+          inherit system;
+          inherit (haskell-nix) config;
+        };
 
-      deferPluginErrors = true;
+      ghcVersion = "ghc921";
-      plutarch-development = true;
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
+        in let pkgs' = nixpkgsFor' system;
         in (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
-          compiler-nix-name = "ghc8107";
+          compiler-nix-name = ghcVersion;
-          cabalProjectFileName = "cabal.project";
+          inherit (plutarch) cabalProjectLocal;
-
+          extraSources = plutarch.extraSources ++ [{
-          # This essentially replaces 'cabal-haskell.nix.project'
+            src = inputs.plutarch;
-          extraSources = [
+            subdirs = [ "." ];
-            {
-              src = inputs.cardano-prelude;
-              subdirs = [ "cardano-prelude" "cardano-prelude-test" ];
-            }
-            {
-              src = inputs.cardano-base;
-              subdirs = [
-                "base-deriving-via"
-                "binary"
-                "binary/test"
-                "cardano-crypto-class"
-                "cardano-crypto-praos"
-                "cardano-crypto-tests"
-                "measures"
-                "orphans-deriving-via"
-                "slotting"
-                "strict-containers"
-              ];
-            }
-
-            {
-              src = inputs.iohk-monitoring-framework;
-              subdirs = [
-                "iohk-monitoring"
-                "tracer-transformers"
-                "contra-tracer"
-                "plugins/backend-aggregation"
-                "plugins/backend-ekg"
-                "plugins/backend-monitoring"
-                "plugins/backend-trace-forwarder"
-                "plugins/scribe-systemd"
-              ];
-            }
-            {
-              src = inputs.cardano-ledger-specs;
-              subdirs = [
-                "byron/ledger/impl"
-                "cardano-ledger-core"
-                "cardano-protocol-tpraos"
-                "eras/alonzo/impl"
-                "eras/byron/chain/executable-spec"
-                "eras/byron/crypto"
-                "eras/byron/crypto/test"
-                "eras/byron/ledger/executable-spec"
-                "eras/byron/ledger/impl/test"
-                "eras/shelley/impl"
-                "eras/shelley-ma/impl"
-                "eras/shelley/chain-and-ledger/executable-spec"
-                "eras/shelley/test-suite"
-                "shelley/chain-and-ledger/shelley-spec-ledger-test"
-                "libs/non-integral"
-                "libs/small-steps"
-                "libs/cardano-ledger-pretty"
-                "semantics/small-steps-test"
-              ];
-            }
-            {
-              src = inputs.ouroboros-network;
-              subdirs = [
-                "monoidal-synchronisation"
-                "typed-protocols"
-                "typed-protocols-cborg"
-                "typed-protocols-examples"
-                "ouroboros-network"
-                "ouroboros-network-testing"
-                "ouroboros-network-framework"
-                "ouroboros-consensus"
-                "ouroboros-consensus-byron"
-                "ouroboros-consensus-cardano"
-                "ouroboros-consensus-shelley"
-                "io-sim"
-                "io-classes"
-                "network-mux"
-                "ntp-client"
-              ];
-            }
-            {
-              src = inputs.servant-purescript;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.purescript-bridge;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.plutarch;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.cardano-addresses;
-              subdirs = [ "core" "command-line" ];
-            }
-            {
-              src = inputs.goblins;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.optparse-applicative;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.cardano-crypto;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.Win32-network;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.flat;
-              subdirs = [ "." ];
-            }
-            {
-              src = inputs.cardano-wallet;
-              subdirs = [
-                "lib/text-class"
-                "lib/strict-non-empty-containers"
-                "lib/core"
-                "lib/test-utils"
-                "lib/numeric"
-                "lib/launcher"
-                "lib/core-integration"
-                "lib/cli"
-                "lib/dbvar"
-                "lib/shelley"
-              ];
-            }
-
-            {
-              src = inputs.plutus-apps;
-              subdirs = [
-                "doc"
-                "freer-extras"
-                "playground-common"
-                "plutus-chain-index"
-                "plutus-chain-index-core"
-                "plutus-contract"
-                "plutus-ledger"
-                "plutus-ledger-constraints"
-                "plutus-pab"
-                "plutus-playground-server"
-                "plutus-use-cases"
-                "quickcheck-dynamic"
-                "web-ghc"
-              ];
-            }
-            {
-              src = inputs.cardano-node;
-              subdirs =
-                [ "cardano-api" "cardano-node" "cardano-cli" "cardano-config" ];
-            }
-            {
-              src = inputs.plutus-extra;
-              subdirs = [
-                "tasty-plutus"
-                "plutus-pretty"
-                "plutus-numeric"
-                "plutus-extra"
-                "plutus-golden"
-                "plutus-laws"
-                "quickcheck-plutus-instances"
-
-              ];
-            }
-            {
-              src = inputs.plutus;
-              subdirs = [
-                "plutus-benchmark"
-                "plutus-core"
-                "plutus-errors"
-                "plutus-ledger-api"
-                "plutus-metatheory"
-                "plutus-tx"
-                "plutus-tx-plugin"
-                "prettyprinter-configurable"
-                "word-array"
-                "stubs/plutus-ghc-stub"
-              ];
-            }
-          ];
-          modules = [{
-            packages = {
-
-              plutarch.flags.development = plutarch-development;
-              marlowe.flags.defer-plugin-errors = deferPluginErrors;
-              plutus-use-cases.flags.defer-plugin-errors = deferPluginErrors;
-              plutus-ledger.flags.defer-plugin-errors = deferPluginErrors;
-              plutus-contract.flags.defer-plugin-errors = deferPluginErrors;
-              cardano-crypto-praos.components.library.pkgconfig =
-                nixpkgs.lib.mkForce
-                [ [ (import plutus { inherit system; }).pkgs.libsodium-vrf ] ];
-              cardano-crypto-class.components.library.pkgconfig =
-                nixpkgs.lib.mkForce
-                [ [ (import plutus { inherit system; }).pkgs.libsodium-vrf ] ];
-            };
           }];
+          modules = [ (plutarch.haskellModule system) ];
           shell = {
             withHoogle = true;
 
             exactDeps = true;
 
-            nativeBuildInputs = with pkgs; [
+            # We use the ones from Nixpkgs, since they are cached reliably.
-              cabal-install
+            # Eventually we will probably want to build these with haskell.nix.
-              hlint
+            nativeBuildInputs = [
-              haskellPackages.fourmolu
+              pkgs'.git
-              nixfmt
+              pkgs'.haskellPackages.apply-refact
-              haskellPackages.cabal-fmt
+              pkgs'.fd
-              haskellPackages.apply-refact
+              pkgs'.cabal-install
-              haskellPackages.record-dot-preprocessor
+              pkgs'.hlint
-              entr
+              pkgs'.haskellPackages.cabal-fmt
-              gnumake
+              pkgs'.nixpkgs-fmt
-
-              graphviz
             ];
 
-            additional = ps: [ ps.plutarch ps.plutus-ledger ps.plutus-extra ];
+            inherit (plutarch) tools;
 
-            tools.haskell-language-server = { };
+            additional = ps: [ ps.plutarch ps.tasty-quickcheck ];
           };
         };
+
+      formatCheckFor = system:
+        let
+          pkgs = nixpkgsFor system;
+          pkgs' = nixpkgsFor' system;
+        in pkgs.runCommand "format-check" {
+          nativeBuildInputs = [
+            pkgs'.git
+            pkgs'.fd
+            pkgs'.haskellPackages.cabal-fmt
+            pkgs'.nixpkgs-fmt
+            (pkgs.haskell-nix.tools ghcVersion {
+              inherit (plutarch.tools) fourmolu;
+            }).fourmolu
+          ];
+        } ''
+          export LC_CTYPE=C.UTF-8
+          export LC_ALL=C.UTF-8
+          export LANG=C.UTF-8
+          cd ${self}
+          make format_check
+          mkdir $out
+        '';
     in {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
       packages = perSystem (system: self.flake.${system}.packages);
-      checks = perSystem (system: self.flake.${system}.checks);
+      checks = perSystem (system:
+        self.flake.${system}.checks // {
+          formatCheck = formatCheckFor system;
+        });
       check = perSystem (system:
         (nixpkgsFor system).runCommand "combined-test" {
-          nativeBuildInputs = builtins.attrValues self.checks.${system};
+          checksss = builtins.attrValues self.checks.${system};
-        } "touch $out");
+        } ''
-      apps = perSystem (system: self.flake.${system}.apps);
+          echo $checksss
-      devShell = perSystem (system:
+          touch $out
-        self.flake.${system}.devShell.overrideAttrs (oldAttrs: {
+        '');
-          buildInputs = (nixpkgsFor system).lib.unique oldAttrs.buildInputs;
+      devShell = perSystem (system: self.flake.${system}.devShell);
-        }));
       defaultPackage =
         perSystem (system: self.flake.${system}.packages."agora:lib:agora");
     };

src/Agora/AuthorityToken.hs

@@ -5,18 +5,20 @@ module Agora.AuthorityToken (
   AuthorityToken (..),
 ) where
 
---------------------------------------------------------------------------------
+import Plutarch.Api.V1 (
+  PScriptContext (..),
+  PScriptPurpose (..),
+  PTxInInfo (..),
+  PTxInfo (..),
+  PTxOut (..),
+ )
+import Plutarch.List (pfoldr')
+import Plutarch.Monadic qualified as P
+import Plutus.V1.Ledger.Value (AssetClass)
 
 import Prelude
 
 --------------------------------------------------------------------------------
-import Plutus.V1.Ledger.Value (AssetClass (..))
-
---------------------------------------------------------------------------------
-
-import Plutarch.Api.V1
-import Plutarch.List (pfoldr')
-import Plutarch.Prelude
 
 import Agora.SafeMoney
 
@@ -29,8 +31,8 @@ import Agora.SafeMoney
      _this_ token's existence in order to prevent incorrect minting.
 -}
 newtype AuthorityToken = AuthorityToken
-  { -- | Token that must move in order for minting this to be valid.
+  { authority :: AssetClass
-    authority :: AssetClass
+  -- ^ Token that must move in order for minting this to be valid.
   }
 
 --------------------------------------------------------------------------------
@@ -40,49 +42,35 @@ authorityTokenPolicy ::
   Term s (PData :--> PScriptContext :--> PUnit)
 authorityTokenPolicy params =
   plam $ \_redeemer ctx' ->
-    pmatch ctx' $ \(PScriptContext ctx) ->
+    pmatch ctx' $ \(PScriptContext ctx') -> P.do
-      let txInfo' = pfromData $ pfield @"txInfo" # ctx
+      ctx <- pletFields @'["txInfo", "purpose"] ctx'
-          purpose' = pfromData $ pfield @"purpose" # ctx
+      PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
-
+      txInfo <- pletFields @'["inputs", "mint"] txInfo'
-          inputs =
+      let inputs = txInfo.inputs :: Term _ (PBuiltinList (PAsData PTxInInfo))
-            pmatch txInfo' $ \(PTxInfo txInfo) ->
+      let authorityTokenInputs =
-              pfromData $ pfield @"inputs" # txInfo
-
-          authorityTokenInputs =
             pfoldr'
-              ( \txInInfo' acc ->
+              ( \txInInfo' acc -> P.do
-                  pmatch (pfromData txInInfo') $ \(PTxInInfo txInInfo) ->
+                  PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
-                    let txOut' =
+                  PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
-                          pfromData $ pfield @"resolved" # txInInfo
+                  txOut <- pletFields @'["value"] txOut'
-                        txOutValue =
+                  let txOutValue = pfromData txOut.value
-                          pmatch txOut' $
+                  passetClassValueOf' params.authority # txOutValue + acc
-                            \(PTxOut txOut) ->
-                              pfromData $ pfield @"value" # txOut
-                     in passetClassValueOf' params.authority # txOutValue + acc
               )
-              # (0 :: Term s PInteger)
+              # 0
               # inputs
-
+      let mintedValue = pfromData txInfo.mint
-          -- We incur the cost twice here. This will be fixed upstream in Plutarch.
+      let tokenMoved = 0 #< authorityTokenInputs
-          mintedValue =
+      PMinting sym' <- pmatch $ pfromData ctx.purpose
-            pmatch txInfo' $ \(PTxInfo txInfo) ->
+      let sym = pfromData $ pfield @"_0" # sym'
-              pfromData $ pfield @"mint" # txInfo
+      let mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
-
+      pif
-          tokenMoved = 0 #< authorityTokenInputs
+        (0 #< mintedATs)
-       in pmatch purpose' $ \case
+        ( pif
-            PMinting sym' ->
+            tokenMoved
-              let sym = pfromData $ pfield @"_0" # sym'
+            -- The authority token moved, we are good to go for minting.
-                  mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
+            (pconstant ())
-               in pif
+            (ptraceError "Authority token did not move in minting GATs")
-                    (0 #< mintedATs)
+        )
-                    ( pif
+        -- We minted 0 or less Authority Tokens, we are good to go.
-                        tokenMoved
+        -- Burning is always allowed.
-                        -- The authority token moved, we are good to go for minting.
+        (pconstant ())
-                        (pconstant ())
-                        (ptraceError "Authority token did not move in minting GATs")
-                    )
-                    -- We minted 0 or less Authority Tokens, we are good to go.
-                    -- Burning is always allowed.
-                    (pconstant ())
-            _ ->
-              ptraceError "Wrong script type"

src/Agora/SafeMoney.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wwarn=missing-methods #-}
 {-# OPTIONS_GHC -Wwarn=unused-imports #-}
 

src/Agora/SafeMoney/QQ.hs

@@ -4,10 +4,8 @@
 
 module Agora.SafeMoney.QQ (discrete) where
 
-import Control.Arrow ((&&&))
-import Data.Ratio (denominator, numerator)
-import Debug.Trace
 import GHC.Real (Ratio ((:%)))
+import Language.Haskell.TH qualified as TH (Type)
 import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
 import Language.Haskell.TH.Syntax (
   Dec (TySynD),
@@ -20,18 +18,15 @@ import Language.Haskell.TH.Syntax (
   Type (AppT, ConT, LitT, PromotedTupleT),
   lookupTypeName,
   reify,
-  reifyType,
  )
-import PlutusTx.Ratio (unsafeRatio)
 import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces)
-import Text.Read (lexP, readMaybe, readPrec_to_P)
+import Text.Read (lexP, readPrec_to_P)
 import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational)
 import Prelude
 
 --------------------------------------------------------------------------------
 
 import Plutarch.Internal (punsafeCoerce)
-import Plutarch.Prelude hiding (Type)
 
 import Agora.SafeMoney
 
@@ -81,7 +76,7 @@ parseDiscreteRatioExp s =
 errorDiscretePat :: String -> Q Pat
 errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context."
 
-errorDiscreteType :: String -> Q Type
+errorDiscreteType :: String -> Q TH.Type
 errorDiscreteType _ = fail "Cannot use 'discrete' in a type context."
 
 errorDiscreteDiscretelaration :: String -> Q [Dec]

src/Agora/Stake.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Vote-lockable stake UTXOs holding GT
 module Agora.Stake (
@@ -22,7 +23,6 @@ import Plutarch.DataRepr (
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Internal
-import Plutarch.Prelude
 
 --------------------------------------------------------------------------------
 
@@ -46,14 +46,14 @@ data StakeAction (gt :: MoneyClass) (s :: S)
 
 newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum
   { getStakeDatum ::
-      ( Term
+    ( Term
-          s
+        s
-          ( PDataRecord
+        ( PDataRecord
-              '[ "stakedAmount" ':= Discrete gt
+            '[ "stakedAmount" ':= Discrete gt
-               , "owner" ':= PPubKeyHash
+             , "owner" ':= PPubKeyHash
-               ]
+             ]
-          )
+        )
-      )
+    )
   }
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
@@ -65,10 +65,10 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum
 assert :: Term s PString -> Term s PBool -> TermCont @r s ()
 assert errorMessage check = TermCont $ \k -> pif check (k ()) (ptraceError errorMessage)
 
-pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
+-- pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
-pfindDatum = phoistAcyclic $
+-- pfindDatum = phoistAcyclic $
-  plam $ \_datumHash _txInfo -> unTermCont $ do
+--   plam $ \_datumHash _txInfo -> unTermCont $ do
-    pure (pcon PNothing)
+--     pure (pcon PNothing)
 
 stakePolicy ::
   forall (gt :: MoneyClass) s.

src/PPrelude.hs

@@ -0,0 +1,7 @@
+module PPrelude (
+  module Prelude,
+  module Plutarch.Prelude,
+) where
+
+import Plutarch.Prelude
+import Prelude