Sulkta-Coop/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into emiflake/stake

Browse source
This commit is contained in:
Emily Martins 2022-02-16 16:41:33 +01:00
commit e9a0d453cf
11 changed files with 276 additions and 1234 deletions
Download patch file Download diff file Expand all files Collapse all files

6
.github/format.sh vendored
View file

@ -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 necessary to tell fourmolu about
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

2
Makefile
View file

@ -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

83
agora.cabal
View file

@ -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
GeneralizedNewtypeDeriving
ForeignFunctionInterface
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:
-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
default-language: Haskell2010
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
, utf8-string
--------------------------------------------------------------------------------
, tasty-quickcheck
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

39
cabal.project
View file

@ -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

870
flake.lock generated
View file

File diff suppressed because it is too large Load diff

371
flake.nix
View file

@ -1,89 +1,18 @@
{
description = "agora";
inputs.haskell-nix.url =
"github:input-output-hk/haskell.nix?rev=4aeeba8d713d0b98c92c8c717df24da17d463c1d";
inputs.nixpkgs.follows = "haskell-nix/nixpkgs-unstable";
inputs.haskell-nix.inputs.nixpkgs.follows = "haskell-nix/nixpkgs-unstable";
inputs.nixpkgs.follows = "plutarch/nixpkgs";
inputs.haskell-nix.follows = "plutarch/haskell-nix";
# Temp workaround for Nix issue.
inputs.nixpkgs-2111.url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin";
# temporary fix for nix versions that have the transitive follows bug
# see https://github.com/NixOS/nix/issues/6013
inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
inputs.plutus.url =
"github:input-output-hk/plutus?rev=65bad0fd53e432974c3c203b1b1999161b6c2dce";
inputs.plutarch.url = "github:Plutonomicon/plutarch";
inputs.plutarch.inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
inputs.plutarch.url =
"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, ... }:
outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }:
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;
plutarch-development = true;
ghcVersion = "ghc921";
projectFor = system:
let pkgs = nixpkgsFor system;
in let pkgs' = nixpkgsFor' system;
in (nixpkgsFor system).haskell-nix.cabalProject' {
src = ./.;
compiler-nix-name = "ghc8107";
cabalProjectFileName = "cabal.project";
# This essentially replaces 'cabal-haskell.nix.project'
extraSources = [
{
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 ] ];
};
compiler-nix-name = ghcVersion;
inherit (plutarch) cabalProjectLocal;
extraSources = plutarch.extraSources ++ [{
src = inputs.plutarch;
subdirs = [ "." ];
}];
modules = [ (plutarch.haskellModule system) ];
shell = {
withHoogle = true;
exactDeps = true;
nativeBuildInputs = with pkgs; [
cabal-install
hlint
haskellPackages.fourmolu
nixfmt
haskellPackages.cabal-fmt
haskellPackages.apply-refact
haskellPackages.record-dot-preprocessor
entr
gnumake
graphviz
# We use the ones from Nixpkgs, since they are cached reliably.
# Eventually we will probably want to build these with haskell.nix.
nativeBuildInputs = [
pkgs'.git
pkgs'.haskellPackages.apply-refact
pkgs'.fd
pkgs'.cabal-install
pkgs'.hlint
pkgs'.haskellPackages.cabal-fmt
pkgs'.nixpkgs-fmt
];
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};
} "touch $out");
apps = perSystem (system: self.flake.${system}.apps);
devShell = perSystem (system:
self.flake.${system}.devShell.overrideAttrs (oldAttrs: {
buildInputs = (nixpkgsFor system).lib.unique oldAttrs.buildInputs;
}));
checksss = builtins.attrValues self.checks.${system};
} ''
echo $checksss
touch $out
'');
devShell = perSystem (system: self.flake.${system}.devShell);
defaultPackage =
perSystem (system: self.flake.${system}.packages."agora:lib:agora");
};

94
src/Agora/AuthorityToken.hs
View file

@ -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) ->
let txInfo' = pfromData $ pfield @"txInfo" # ctx
purpose' = pfromData $ pfield @"purpose" # ctx
inputs =
pmatch txInfo' $ \(PTxInfo txInfo) ->
pfromData $ pfield @"inputs" # txInfo
authorityTokenInputs =
pmatch ctx' $ \(PScriptContext ctx') -> P.do
ctx <- pletFields @'["txInfo", "purpose"] ctx'
PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
txInfo <- pletFields @'["inputs", "mint"] txInfo'
let inputs = txInfo.inputs :: Term _ (PBuiltinList (PAsData PTxInInfo))
let authorityTokenInputs =
pfoldr'
( \txInInfo' acc ->
pmatch (pfromData txInInfo') $ \(PTxInInfo txInInfo) ->
let txOut' =
pfromData $ pfield @"resolved" # txInInfo
txOutValue =
pmatch txOut' $
\(PTxOut txOut) ->
pfromData $ pfield @"value" # txOut
in passetClassValueOf' params.authority # txOutValue + acc
( \txInInfo' acc -> P.do
PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
txOut <- pletFields @'["value"] txOut'
let txOutValue = pfromData txOut.value
passetClassValueOf' params.authority # txOutValue + acc
)
# (0 :: Term s PInteger)
# 0
# inputs
-- We incur the cost twice here. This will be fixed upstream in Plutarch.
mintedValue =
pmatch txInfo' $ \(PTxInfo txInfo) ->
pfromData $ pfield @"mint" # txInfo
tokenMoved = 0 #< authorityTokenInputs
in pmatch purpose' $ \case
PMinting sym' ->
let sym = pfromData $ pfield @"_0" # sym'
mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
in pif
(0 #< mintedATs)
( pif
tokenMoved
-- The authority token moved, we are good to go for minting.
(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"
let mintedValue = pfromData txInfo.mint
let tokenMoved = 0 #< authorityTokenInputs
PMinting sym' <- pmatch $ pfromData ctx.purpose
let sym = pfromData $ pfield @"_0" # sym'
let mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
pif
(0 #< mintedATs)
( pif
tokenMoved
-- The authority token moved, we are good to go for minting.
(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 ())

1
src/Agora/SafeMoney.hs
View file

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

11
src/Agora/SafeMoney/QQ.hs
View file

@ -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]

26
src/Agora/Stake.hs
View file

@ -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
s
( PDataRecord
'[ "stakedAmount" ':= Discrete gt
, "owner" ':= PPubKeyHash
]
)
)
( Term
s
( PDataRecord
'[ "stakedAmount" ':= Discrete gt
, "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 = phoistAcyclic $
plam $ \_datumHash _txInfo -> unTermCont $ do
pure (pcon PNothing)
-- pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
-- pfindDatum = phoistAcyclic $
-- plam $ \_datumHash _txInfo -> unTermCont $ do
-- pure (pcon PNothing)
stakePolicy ::
forall (gt :: MoneyClass) s.

7
src/PPrelude.hs Normal file
View file

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