diff --git a/.github/format.sh b/.github/format.sh deleted file mode 100755 index db31a21..0000000 --- a/.github/format.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash - -# Extensions necessary to tell fourmolu about -EXTENSIONS="-o -XTypeApplications -o -XTemplateHaskell -o -XImportQualifiedPost -o -XPatternSynonyms -o -fplugin=RecordDotPreprocessor -o -XBangPatterns" -SOURCES=$(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') -fourmolu --mode check --check-idempotence $EXTENSIONS $SOURCES diff --git a/.github/workflows/integrate.yaml b/.github/workflows/integrate.yaml deleted file mode 100644 index dfcc81b..0000000 --- a/.github/workflows/integrate.yaml +++ /dev/null @@ -1,78 +0,0 @@ -on: - push: - paths: - - '**.hs' - - '**.nix' - - 'nix/sources.json' - - 'apropos-tx.cabal' - - '.github/*' - - '.github/workflows/*' - branches: - - main - - master - - staging - pull_request: - paths: - - '**.hs' - - '**.nix' - - 'nix/sources.json' - - 'apropos-tx.cabal' -jobs: - fourmolu-check: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v2 - - uses: cachix/install-nix-action@v13 - name: Set up nix and IOHK cache - with: - nix_path: nixpkgs=channel:nixos-21.11 - extra_nix_config: | - trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= - substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ - experimental-features = nix-command flakes - - uses: cachix/cachix-action@v10 - with: - name: mlabs - authToken: ${{ secrets.CACHIX_KEY }} - - run: nix-env -iA haskellPackages.fourmolu -f '' - name: Install fourmolu - - run: ./.github/format.sh - name: Format - hlint-check: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v2 - - uses: cachix/install-nix-action@v13 - name: Set up nix and IOHK cache - with: - nix_path: nixpkgs=channel:nixos-21.11 - extra_nix_config: | - trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= - substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ - experimental-features = nix-command flakes - - uses: cachix/cachix-action@v10 - with: - name: mlabs - authToken: ${{ secrets.CACHIX_KEY }} - - run: nix-env -iA hlint -f '' - name: Install hlint - - run: hlint $(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') - name: Lint - cabal-check: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v2 - - uses: cachix/install-nix-action@v13 - name: Set up nix and IOHK cache - with: - nix_path: nixpkgs=channel:nixos-21.11 - extra_nix_config: | - trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= - substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ - experimental-features = nix-command flakes - - uses: cachix/cachix-action@v10 - with: - name: mlabs - authToken: ${{ secrets.CACHIX_KEY }} - - name: Build the full ci derivation - run: nix build .#check.x86_64-linux diff --git a/.gitignore b/.gitignore index 80a8c65..c1c8fb0 100644 --- a/.gitignore +++ b/.gitignore @@ -50,3 +50,7 @@ cabal.project.local* # ctags tags TAGS + +# Local hoogle +.hoogle +.haddock diff --git a/Makefile b/Makefile index 2b1aedc..b724b05 100644 --- a/Makefile +++ b/Makefile @@ -2,8 +2,6 @@ # are made availible by the nix shell defined in shell.nix. # In most cases you should execute Make after entering nix-shell. -SHELL := /usr/bin/env bash - .PHONY: hoogle build test watch ghci readme_contents \ format lint refactor requires_nix_shell @@ -25,16 +23,20 @@ usage: @echo " format_check -- Check source code formatting without making changes" @echo " cabalfmt -- Apply cabal formatting with cabal-fmt" @echo " cabalfmt_check -- Check cabal files for formatting errors without making changes" - @echo " nixfmt -- Apply nix formatting with nixfmt" - @echo " nixfmt_check -- Check nix files for format errors" + @echo " nixpkgsfmt -- Apply nix formatting with nixpkgs-fmt" + @echo " nixpkgsfmt_check -- Check nix files for format errors" @echo " lint -- Check the sources with hlint" @echo " refactor_cautious -- Automatically apply hlint refactors, with prompt" @echo " refactor -- Automatically apply hlint refactors, without prompt" @echo " readme_contents -- Add table of contents to README" @echo " update_plutus -- Update plutus version with niv" + @echo " haddock -- Generate haddock docs. hoogle: requires_nix_shell - hoogle server --local + pkill hoogle || true + hoogle generate --local=.haddock --database=.hoogle/local.hoo + hoogle server --local -p 8080 >> /dev/null & + hoogle server --local --database=.hoogle/local.hoo -p 8081 >> /dev/null & STACK_EXE_PATH = $(shell stack $(STACK_FLAGS) path --local-install-root)/bin @@ -71,7 +73,7 @@ format: requires_nix_shell format_check: requires_nix_shell fourmolu --mode check --check-idempotence $(FORMAT_EXTENSIONS) $(FORMAT_SOURCES) -CABAL_SOURCES := $(shell git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' ) +CABAL_SOURCES := $(shell fd -ecabal) cabalfmt: requires_nix_shell cabal-fmt --inplace $(CABAL_SOURCES) @@ -80,13 +82,13 @@ cabalfmt_check: requires_nix_shell cabal-fmt --check $(CABAL_SOURCES) # Nix files to format -NIX_SOURCES := $(shell git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix' ) +NIX_SOURCES := $(shell fd -enix) -nixfmt: requires_nix_shell - nixfmt $(NIX_SOURCES) +nixpkgsfmt: requires_nix_shell + nixpkgs-fmt $(NIX_SOURCES) -nixfmt_check: requires_nix_shell - nixfmt --check $(NIX_SOURCES) +nixpkgsfmt_check: requires_nix_shell + nixpkgs-fmt --check $(NIX_SOURCES) # Check with hlint, currently I couldn't get --refactor to work lint: requires_nix_shell @@ -123,3 +125,6 @@ update_plutus: @echo "Make sure to update the plutus rev in cabal.project with:" @echo " commit: $(PLUTUS_REV)" @echo "This may require further resolution of dependency versions." + +haddock: requires_nix_shell + cabal haddock --haddock-html --haddock-hoogle --builddir=.haddock diff --git a/apropos-tx.cabal b/apropos-tx.cabal index 339e91e..f63869a 100644 --- a/apropos-tx.cabal +++ b/apropos-tx.cabal @@ -40,6 +40,7 @@ common lang build-depends: , apropos , base >=4.14 + , bytestring , containers , free , hedgehog @@ -49,6 +50,7 @@ common lang , plutarch , plutus-core , plutus-ledger-api + , plutus-tx , pretty , pretty-show , safe @@ -64,6 +66,18 @@ common lang library import: lang exposed-modules: + Apropos.Gen.Address + Apropos.Gen.Api + Apropos.Gen.Contexts + Apropos.Gen.Credential + Apropos.Gen.Crypto + Apropos.Gen.DCert + Apropos.Gen.Extra + Apropos.Gen.Interval + Apropos.Gen.Scripts + Apropos.Gen.Time + Apropos.Gen.TxId + Apropos.Gen.Value Apropos.Script Apropos.Tx @@ -88,6 +102,9 @@ test-suite examples , containers , hedgehog , mtl + , plutarch + , plutus-core + , plutus-ledger-api , tasty , tasty-hedgehog , text diff --git a/examples/Spec/Int.hs b/examples/Spec/Int.hs index e3d6c54..cd8c11a 100644 --- a/examples/Spec/Int.hs +++ b/examples/Spec/Int.hs @@ -56,12 +56,12 @@ instance HasParameterisedGenerator IntProp Int where else if IsMaxBound `elem` s then pure maxBound - else int (linear 11 (maxBound -1)) + else int (linear 11 (maxBound - 1)) if IsNegative `elem` s then if IsMinBound `elem` s then pure minBound - else pure (- i) + else pure (-i) else pure i intGenTests :: TestTree diff --git a/examples/Spec/IntPermutationGen.hs b/examples/Spec/IntPermutationGen.hs index 6565bee..9d1580c 100644 --- a/examples/Spec/IntPermutationGen.hs +++ b/examples/Spec/IntPermutationGen.hs @@ -67,7 +67,7 @@ instance HasPermutationGenerator IntProp Int where { name = "MakeLarge" , match = Not $ Var IsLarge , contract = clear >> addAll [IsLarge, IsPositive] - , morphism = \_ -> int (linear 11 (maxBound -1)) + , morphism = \_ -> int (linear 11 (maxBound - 1)) } , Morphism { name = "MakeSmall" @@ -83,7 +83,7 @@ instance HasPermutationGenerator IntProp Int where [ has IsNegative >> remove IsNegative >> add IsPositive , has IsPositive >> remove IsPositive >> add IsNegative ] - , morphism = \i -> pure (- i) + , morphism = \i -> pure (-i) } ] diff --git a/examples/Spec/Plutarch/CostModel.hs b/examples/Spec/Plutarch/CostModel.hs index 5c06fdd..4c09953 100644 --- a/examples/Spec/Plutarch/CostModel.hs +++ b/examples/Spec/Plutarch/CostModel.hs @@ -24,7 +24,7 @@ numCostModels = 10 peano :: Integer -> Term s PInteger peano 0 = 0 -peano i = papp (plam (+ 1)) (peano (i -1)) +peano i = papp (plam (+ 1)) (peano (i - 1)) addCost :: Integer -> Script addCost i = compile $ peano i diff --git a/examples/Spec/Plutarch/MagicNumber.hs b/examples/Spec/Plutarch/MagicNumber.hs index 376840f..02d5c54 100644 --- a/examples/Spec/Plutarch/MagicNumber.hs +++ b/examples/Spec/Plutarch/MagicNumber.hs @@ -28,7 +28,7 @@ numMagicNumbers = 4 -- accepts a range of numbers determined by a Magic Number magicNumber :: Integer -> Script -magicNumber i = compile $ plam $ \ii -> pif ((pfromData ii #<= (fromInteger i :: Term s PInteger)) #&& ((fromInteger (- i) :: Term s PInteger) #<= pfromData ii)) (pcon PUnit) perror +magicNumber i = compile $ plam $ \ii -> pif ((pfromData ii #<= (fromInteger i :: Term s PInteger)) #&& ((fromInteger (-i) :: Term s PInteger) #<= pfromData ii)) (pcon PUnit) perror data MagicNumberProp = HalfWidth Integer deriving stock (Eq, Ord, Show) diff --git a/flake.nix b/flake.nix index db88fb2..3aa676c 100644 --- a/flake.nix +++ b/flake.nix @@ -21,12 +21,14 @@ nixpkgsFor = system: import nixpkgs { inherit system; overlays = [ haskell-nix.overlay ]; inherit (haskell-nix) config; }; + fourmoluFor = system: (nixpkgsFor system).haskell-nix.tool "ghc8107" "fourmolu" { }; + projectFor = system: let deferPluginErrors = true; pkgs = nixpkgsFor system; - fakeSrc = pkgs.runCommand "real-source" {} '' + fakeSrc = pkgs.runCommand "real-source" { } '' cp -rT ${self} $out chmod u+w $out/cabal.project cat $out/cabal-haskell.nix.project >> $out/cabal.project @@ -55,7 +57,7 @@ # We use the ones from Nixpkgs, since they are cached reliably. # Eventually we will probably want to build these with haskell.nix. - nativeBuildInputs = [ pkgs.cabal-install pkgs.hlint pkgs.haskellPackages.fourmolu ]; + nativeBuildInputs = with pkgs; [ cabal-install hlint (fourmoluFor system) fd haskellPackages.cabal-fmt nixpkgs-fmt coreutils ]; additional = ps: [ ps.plutarch @@ -63,43 +65,47 @@ ]; }; sha256map = { - "https://github.com/Plutonomicon/plutarch"."f8b7eb06184112ae2bebdec5a8156010141a05d5" - = "sha256-y9lalsaTFVEPCoE/P8d4bduJJLSBvVpo/791mI9kcO4="; - "https://github.com/mlabs-haskell/apropos"."3734bb3baa297ed990725a5ef14efcbb6a1c1c23" - = "sha256-C2gQrd5hFvQ+BsjAJs6V0iP9PRzd9dZMKtpk7kOjhwc="; - "https://github.com/input-output-hk/plutus.git"."6d8d25d1e84b2a4278da1036aab23da4161b8df8" - = "o8m86TkI1dTo74YbE9CPPNrBfSDSrf//DMq+v2+woEY="; - "https://github.com/Quid2/flat.git"."ee59880f47ab835dbd73bea0847dab7869fc20d8" - = "lRFND+ZnZvAph6ZYkr9wl9VAx41pb3uSFP8Wc7idP9M="; - "https://github.com/input-output-hk/cardano-crypto.git"."07397f0e50da97eaa0575d93bee7ac4b2b2576ec" - = "oxIOVlgm07FAEmgGRF1C2me9TXqVxQulEOcJ22zpTRs="; - "https://github.com/input-output-hk/cardano-base"."78b3928391b558fb1750228f63301ec371f13528" - = "pBUTTcenaSLMovHKGsaddJ7Jh3okRTrtu5W7Rdu6RM4="; - "https://github.com/input-output-hk/cardano-prelude"."fd773f7a58412131512b9f694ab95653ac430852" - = "BtbT5UxOAADvQD4qTPNrGfnjQNgbYNO4EAJwH2ZsTQo="; - "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" - = "Hesb5GXSx0IwKSIi42ofisVELcQNX6lwHcoZcbaDiqc="; + "https://github.com/Plutonomicon/plutarch"."f8b7eb06184112ae2bebdec5a8156010141a05d5" = "sha256-y9lalsaTFVEPCoE/P8d4bduJJLSBvVpo/791mI9kcO4="; + "https://github.com/mlabs-haskell/apropos"."3734bb3baa297ed990725a5ef14efcbb6a1c1c23" = "sha256-C2gQrd5hFvQ+BsjAJs6V0iP9PRzd9dZMKtpk7kOjhwc="; + "https://github.com/input-output-hk/plutus.git"."6d8d25d1e84b2a4278da1036aab23da4161b8df8" = "o8m86TkI1dTo74YbE9CPPNrBfSDSrf//DMq+v2+woEY="; + "https://github.com/Quid2/flat.git"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "lRFND+ZnZvAph6ZYkr9wl9VAx41pb3uSFP8Wc7idP9M="; + "https://github.com/input-output-hk/cardano-crypto.git"."07397f0e50da97eaa0575d93bee7ac4b2b2576ec" = "oxIOVlgm07FAEmgGRF1C2me9TXqVxQulEOcJ22zpTRs="; + "https://github.com/input-output-hk/cardano-base"."78b3928391b558fb1750228f63301ec371f13528" = "pBUTTcenaSLMovHKGsaddJ7Jh3okRTrtu5W7Rdu6RM4="; + "https://github.com/input-output-hk/cardano-prelude"."fd773f7a58412131512b9f694ab95653ac430852" = "BtbT5UxOAADvQD4qTPNrGfnjQNgbYNO4EAJwH2ZsTQo="; + "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "Hesb5GXSx0IwKSIi42ofisVELcQNX6lwHcoZcbaDiqc="; }; }; + formatCheckFor = system: + let + pkgs = nixpkgsFor system; + in + pkgs.runCommand "format-check" + { + nativeBuildInputs = [ self.devShell.${system}.nativeBuildInputs ]; + } '' + cd ${self} + IN_NIX_SHELL=true make format_check cabalfmt_check nixpkgsfmt_check lint + mkdir $out + ''; in { - ciNix = flake-compat-ci.lib.recurseIntoFlakeWith { - flake = self; - systems = [ "x86_64-linux" ]; - }; - project = perSystem projectFor; - flake = perSystem (system: (projectFor system).flake {}); + flake = perSystem (system: (projectFor system).flake { }); # this could be done automatically, but would reduce readability 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" + (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); + + herculesCI.ciSystems = [ "x86_64-linux" ]; }; } diff --git a/src/Apropos/Gen/Address.hs b/src/Apropos/Gen/Address.hs new file mode 100644 index 0000000..268ef95 --- /dev/null +++ b/src/Apropos/Gen/Address.hs @@ -0,0 +1,22 @@ +{- | +Module: Apropos.Gen.Address +Description: Address generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Address` types. +-} +module Apropos.Gen.Address (address) where + +import Apropos.Gen (Gen) +import Apropos.Gen.Credential (credential, stakingCredential) +import Apropos.Gen.Extra qualified as Gen (maybe) +import Plutus.V1.Ledger.Address ( + Address (Address), + ) + +-- | Generator for Plutus `Address` types. +address :: Gen Address +address = do + cred <- credential + scred <- Gen.maybe stakingCredential + return $ Address cred scred diff --git a/src/Apropos/Gen/Api.hs b/src/Apropos/Gen/Api.hs new file mode 100644 index 0000000..4da4a42 --- /dev/null +++ b/src/Apropos/Gen/Api.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Module: Apropos.Gen.Api +Description: Misc. Plutus generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Api` types. +-} +module Apropos.Gen.Api ( + builtinByteString, + -- builtinData, +) where + +import Apropos.Gen (Gen, choice, int, linear, list, singleton) +import Apropos.Gen.Extra (integer, pair, sha256) +import PlutusTx (Data (B, Constr, I, List, Map)) +import PlutusTx.Builtins.Internal ( + BuiltinByteString (BuiltinByteString), + BuiltinData (BuiltinData), + ) + +-- | `Gen` for Plutus `BuiltinByteString`. +builtinByteString :: Gen BuiltinByteString +builtinByteString = do + bs <- sha256 + return $ BuiltinByteString bs + +-- | `Gen` for Plutus `BuiltinData`. +builtinData :: Gen BuiltinData +builtinData = do + d <- data' + return $ BuiltinData d + +-- | TODO: Re-do; too slow. `Gen` for Plutus `Data`. +data' :: Gen Data +data' = do + let constrGen = do + len <- int (linear 0 50) + l <- list (singleton len) data' + let i = toInteger len + return $ Constr i l + choice + [ constrGen + , Map <$> list (linear 0 20) (pair data' data') + , List <$> list (linear 0 10) data' + , I <$> integer (linear minBound maxBound) + , B <$> sha256 + ] diff --git a/src/Apropos/Gen/Contexts.hs b/src/Apropos/Gen/Contexts.hs new file mode 100644 index 0000000..da534bd --- /dev/null +++ b/src/Apropos/Gen/Contexts.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Module: Apropos.Gen.Context +Description: Plutus context generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Context` types. +-} +module Apropos.Gen.Contexts ( + scriptContext, + txInfo, + txInInfo, + txOut, + scriptPurpose, + txOutRef, +) where + +import Apropos.Gen (Gen, choice, element, linear, list) +import Apropos.Gen.Address (address) +import Apropos.Gen.Credential (stakingCredential) +import Apropos.Gen.Crypto (pubKeyHash) +import Apropos.Gen.DCert (dCert) +import Apropos.Gen.Extra (integer, pair) +import Apropos.Gen.Extra qualified as Gen (maybe) + +-- import Apropos.Gen.Scripts (datum, datumHash) +import Apropos.Gen.Scripts (datumHash) +import Apropos.Gen.Time (posixTimeRange) +import Apropos.Gen.TxId (txId) +import Apropos.Gen.Value (currencySymbol, value) +import Plutus.V1.Ledger.Contexts ( + ScriptContext (ScriptContext), + ScriptPurpose (Certifying, Minting, Rewarding, Spending), + TxInInfo (TxInInfo), + TxInfo ( + TxInfo, + txInfoDCert, + txInfoData, + txInfoFee, + txInfoId, + txInfoInputs, + txInfoMint, + txInfoOutputs, + txInfoSignatories, + txInfoValidRange, + txInfoWdrl + ), + TxOut (TxOut), + TxOutRef (TxOutRef), + ) + +-- | `Gen` for Plutus `ScriptContext`s. +scriptContext :: Gen ScriptContext +scriptContext = do + i <- txInfo + p <- scriptPurpose + return $ ScriptContext i p + +-- | `Gen` for Plutus `TxInfo`s. +txInfo :: Gen TxInfo +txInfo = do + ins <- list (linear 1 5) txInInfo + outs <- list (linear 1 5) txOut + fee <- value + mint <- value + dCert' <- list (linear 1 10) dCert + wdrl <- + list (linear 0 10) $ + pair stakingCredential $ + integer (linear 0 50) + range <- posixTimeRange (linear 0 2000) (linear 6000 maxBound) + sigs <- list (linear 0 10) pubKeyHash + -- data' <- list (linear 1 5) $ pair datumHash datum + id' <- txId + return $ + TxInfo + { txInfoInputs = ins + , txInfoOutputs = outs + , txInfoFee = fee + , txInfoMint = mint + , txInfoDCert = dCert' + , txInfoWdrl = wdrl + , txInfoValidRange = range + , txInfoSignatories = sigs + , -- , txInfoData = data' + txInfoData = [] + , txInfoId = id' + } + +-- | `Gen` for Plutus `TxInInfo`s. +txInInfo :: Gen TxInInfo +txInInfo = do + oRef <- txOutRef + o <- txOut + return $ TxInInfo oRef o + +-- | `Gen` for Plutus `TxOut`s. +txOut :: Gen TxOut +txOut = do + a <- address + v <- value + h <- Gen.maybe datumHash + return $ TxOut a v h + +-- | `Gen` for Plutus `ScriptPurpose`s. +scriptPurpose :: Gen ScriptPurpose +scriptPurpose = do + choice + [ Minting <$> currencySymbol + , Spending <$> txOutRef + , Rewarding <$> stakingCredential + , Certifying <$> dCert + ] + +-- | `Gen` for Plutus `TxOutRef`s. +txOutRef :: Gen TxOutRef +txOutRef = do + id' <- txId + idx <- integer (linear 0 maxBound) + return $ TxOutRef id' idx diff --git a/src/Apropos/Gen/Credential.hs b/src/Apropos/Gen/Credential.hs new file mode 100644 index 0000000..a3f5e83 --- /dev/null +++ b/src/Apropos/Gen/Credential.hs @@ -0,0 +1,34 @@ +{- | +Module: Apropos.Gen.Credential +Description: Plutus credential generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Credential` types. +-} +module Apropos.Gen.Credential (credential, stakingCredential) where + +import Apropos.Gen (Gen, choice, linear) +import Apropos.Gen.Crypto (pubKeyHash) +import Apropos.Gen.Extra (integer) +import Apropos.Gen.Scripts (validatorHash) +import Plutus.V1.Ledger.Credential ( + Credential (PubKeyCredential, ScriptCredential), + StakingCredential (StakingHash, StakingPtr), + ) + +-- | `Gen` for Plutus `Credential`s. +credential :: Gen Credential +credential = + choice + [ PubKeyCredential <$> pubKeyHash + , ScriptCredential <$> validatorHash + ] + +-- | `Gen` for Plutus `StakingCredential`s. +stakingCredential :: Gen StakingCredential +stakingCredential = + let p = integer $ linear 0 1000 + in choice + [ StakingHash <$> credential + , StakingPtr <$> p <*> p <*> p + ] diff --git a/src/Apropos/Gen/Crypto.hs b/src/Apropos/Gen/Crypto.hs new file mode 100644 index 0000000..ecd8a40 --- /dev/null +++ b/src/Apropos/Gen/Crypto.hs @@ -0,0 +1,18 @@ +{- | +Module: Apropos.Gen.Crypto +Description: Plutus crypto type generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Crypto` types. +-} +module Apropos.Gen.Crypto (pubKeyHash) where + +import Apropos.Gen (Gen) +import Apropos.Gen.Api (builtinByteString) +import Plutus.V1.Ledger.Crypto (PubKeyHash (PubKeyHash)) + +-- | `Gen` for Plutus `PubKeyHash`s. +pubKeyHash :: Gen PubKeyHash +pubKeyHash = do + bs <- builtinByteString + return $ PubKeyHash bs diff --git a/src/Apropos/Gen/DCert.hs b/src/Apropos/Gen/DCert.hs new file mode 100644 index 0000000..9025466 --- /dev/null +++ b/src/Apropos/Gen/DCert.hs @@ -0,0 +1,37 @@ +{- | +Module: Apropos.Gen.DCert +Description: Plutus dcert generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.DCert` types. +-} +module Apropos.Gen.DCert (dCert) where + +import Apropos.Gen (Gen, choice, linear) +import Apropos.Gen.Credential (stakingCredential) +import Apropos.Gen.Crypto (pubKeyHash) +import Apropos.Gen.Extra (integer) +import Plutus.V1.Ledger.DCert ( + DCert ( + DCertDelegDeRegKey, + DCertDelegDelegate, + DCertDelegRegKey, + DCertGenesis, + DCertMir, + DCertPoolRegister, + DCertPoolRetire + ), + ) + +-- | `Gen` for Plutus `DCert`s. +dCert :: Gen DCert +dCert = do + choice + [ DCertDelegRegKey <$> stakingCredential + , DCertDelegDeRegKey <$> stakingCredential + , DCertDelegDelegate <$> stakingCredential <*> pubKeyHash + , DCertPoolRegister <$> pubKeyHash <*> pubKeyHash + , DCertPoolRetire <$> pubKeyHash <*> integer (linear 0 300) + , return DCertGenesis + , return DCertMir + ] diff --git a/src/Apropos/Gen/Extra.hs b/src/Apropos/Gen/Extra.hs new file mode 100644 index 0000000..11c758a --- /dev/null +++ b/src/Apropos/Gen/Extra.hs @@ -0,0 +1,208 @@ +{- | +Module: Apropos.Gen.Extra +Description: Generator helper functions. +Maintainer: jack@mlabs.city + +Helper functions for `Apropos.Gen`. +-} +module Apropos.Gen.Extra ( + sha256, + map, + pair, + integer, + maybe, + upperChar, + lowerChar, + numChar, + numericString, + alphaText, + alphanumericText, + numericText, + alphaBS, + alphanumericBS, + numericBS, +) where + +import Apropos.Gen (Gen, choice, element, int, list) +import Apropos.Gen.Range (Range, singleton) +import Data.ByteString (ByteString) +import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) +import PlutusTx.AssocMap (Map, fromList) +import Prelude hiding (map, maybe) + +-- | Creates a generator for a 2-tuple. +pair :: + -- | Generator for the type of the first element. + Gen a -> + -- | Generator for the type of the second element. + Gen b -> + -- | Generator for a pair of a value of the first type and a + -- value of the second type. + Gen (a, b) +pair genA genB = do + a <- genA + b <- genB + return (a, b) + +-- | Function producing a generator for an `Integer`. +integer :: + -- | Provides min and max bound for the integer to be + -- generated. + Range -> + -- | The `Integer` generator. + Gen Integer +integer r = toInteger <$> int r + +-- | Function producing a generator for a `Maybe` type. +maybe :: + -- | A generator for the type to be wrapped by the `Maybe` + -- monad. + Gen a -> + -- | A generator for the desired `Maybe` type. + Gen (Maybe a) +maybe genA = choice [Just <$> genA, return Nothing] + +{- | Given a generator for a key-type k and a value-type v + returns a generator for a `Map` k v. +-} +map :: + -- | `Range` for the number of map entries. + Range -> + -- | Generator for the desired type of the keys. + Gen k -> + -- | Generator for the desired type of the values. + Gen v -> + -- | Generator for a map. + Gen (Map k v) -- +map r genK genV = do + ks <- list r genK + vs <- list r genV + let mapList = zip ks vs + return $ fromList mapList + +-- | Generator for an upper case alphabetic character. +upperChar :: Gen Char +upperChar = element ['A' .. 'Z'] + +-- | Generator for a lower case alphaberic character. +lowerChar :: Gen Char +lowerChar = element ['a' .. 'z'] + +-- | Generator for a numeric character. +numChar :: Gen Char +numChar = element ['0' .. '9'] + +-- | Generator for a hexademical character. +hexChar :: Gen Char +hexChar = element $ ['0' .. '9'] ++ ['a' .. 'f'] + +-- | Returns a generator for a mixed case alphabetic string. +alphaString :: + -- | `Range` for the length of the string. + Range -> + Gen String +alphaString r = list r gen + where + gen = choice [upperChar, lowerChar] + +-- | Returns a generator for a mixed case alphanumeric string. +alphanumericString :: + -- | `Range` for the length of the string. + Range -> + Gen String +alphanumericString r = list r gen + where + gen = choice [upperChar, lowerChar, numChar] + +-- | Returns a generator for a numeric string. +numericString :: + -- | `Range` for the length of the string. + Range -> + Gen String +numericString r = list r numChar + +-- | Return a generator for a hexadecimal string. +hexString :: + -- | `Range` for the length of the string. + Range -> + Gen String +hexString r = list r hexChar + +{- | Auxiliary function for creating text generation functions + from string generation functions. +-} +genText :: + -- | Existing string generation function e.g. `alphaString`. + (Range -> Gen String) -> + -- | Function taking a `Range` and producing a `Text` generator. + (Range -> Gen Text) +genText f r = pack <$> f r + +-- | Return a generator for an alphabetic `Text` string. +alphaText :: + -- | Length of desired string. + Range -> + Gen Text +alphaText = genText alphaString + +-- | Return a generator for an alphanumeric `Text` string. +alphanumericText :: + -- | Length of desired string. + Range -> + Gen Text +alphanumericText = genText alphanumericString + +-- | Return a generator for a numeric `Text` string. +numericText :: + -- | Length of desired string. + Range -> + Gen Text +numericText = genText alphaString + +-- | Return a generator for a hexadecimal `Text` string. +hexText :: + -- | Length of desired string. + Range -> + Gen Text +hexText = genText hexString + +-- | Auxiliary function for creating `ByteString` generators. +genBS :: + -- | Preexisting `Text` generation function e.g. `alphaText`. + (Range -> Gen Text) -> + -- | Desired `ByteString` generation function. + (Range -> Gen ByteString) +genBS f r = encodeUtf8 <$> f r + +-- | Return a generator for an alphabetic `ByteString`. +alphaBS :: + -- | Length of desired string. + Range -> + Gen ByteString +alphaBS = genBS alphaText + +-- | Return a generator for an alphanumeric `ByteString`. +alphanumericBS :: + -- | Length of desired string. + Range -> + Gen ByteString +alphanumericBS = genBS alphanumericText + +-- | Return a generator for an numeric `ByteString`. +numericBS :: + -- | Length of desired string. + Range -> + Gen ByteString +numericBS = genBS numericText + +-- | Return a generator for an hexadecimal `ByteString`. +hexBS :: + -- | Length of desired string. + Range -> + Gen ByteString +hexBS = genBS hexText + +-- | Return a generator for SHA256 hash. +sha256 :: Gen ByteString +sha256 = hexBS $ singleton 64 diff --git a/src/Apropos/Gen/Interval.hs b/src/Apropos/Gen/Interval.hs new file mode 100644 index 0000000..994e6fc --- /dev/null +++ b/src/Apropos/Gen/Interval.hs @@ -0,0 +1,67 @@ +{- | +Module: Apropos.Gen.Interval +Description: Plutus interval generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Interval` types. +-} +module Apropos.Gen.Interval (interval, extendedF, extendedI) where + +import Apropos.Gen (Gen, element) +import Plutus.V1.Ledger.Interval ( + Extended (Finite, NegInf, PosInf), + Interval (Interval), + LowerBound (LowerBound), + UpperBound (UpperBound), + ) + +{- | Given two generators for a type @a@, will return a generator + for type `Interval` @a@, where the lower bound has been + generated by the first generator and the upper bound + by the second. +-} +interval :: + Show a => + -- | Generator for the lower bound. + Gen a -> + -- | Generator for the upper bound. + Gen a -> + -- | Generator for the interval. + Gen (Interval a) +interval g0 g1 = do + l <- lowerBound g0 + u <- upperBound g1 + return $ Interval l u + +{- | Given a generator for a type @a@, will return a generator + for type `LowerBound` @a@. +-} +lowerBound :: Show a => Gen a -> Gen (LowerBound a) +lowerBound g = do + e <- extendedF g + c <- element [True, False] + return $ LowerBound e c + +{- | Given a generator for a type @a@, will return a generator + for type `UpperBound` @a@. +-} +upperBound :: Show a => Gen a -> Gen (UpperBound a) +upperBound g = do + e <- extendedF g + c <- element [True, False] + return $ UpperBound e c + +-- | Generator for `Extended` @a@ that must be finite. +extendedF :: Show a => Gen a -> Gen (Extended a) +extendedF = extended False + +-- | Generator for `Extended` @a@ that can be infinite. +extendedI :: Show a => Gen a -> Gen (Extended a) +extendedI = extended True + +extended :: Show a => Bool -> Gen a -> Gen (Extended a) +extended allowInfinite g = do + x <- g + if allowInfinite + then element [NegInf, Finite x, PosInf] + else return $ Finite x diff --git a/src/Apropos/Gen/Scripts.hs b/src/Apropos/Gen/Scripts.hs new file mode 100644 index 0000000..6bd05a7 --- /dev/null +++ b/src/Apropos/Gen/Scripts.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{- | +Module: Apropos.Gen.Scripts +Description: Script generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Scripts` types. +-} +module Apropos.Gen.Scripts ( + validatorHash, + -- datum, + datumHash, +) where + +import Apropos.Gen (Gen) + +-- import Apropos.Gen.Api (builtinByteString, builtinData) +import Apropos.Gen.Api (builtinByteString) +import Plutus.V1.Ledger.Scripts ( + Datum (Datum), + DatumHash (DatumHash), + ValidatorHash (ValidatorHash), + ) + +-- -- | Generator for Plutus `Datum` type. +-- datum :: Gen Datum +-- datum = do +-- bid <- builtinData +-- return $ Datum bid + +-- | Generator for Plutus `DatumHash` type. +datumHash :: Gen DatumHash +datumHash = do + bs <- builtinByteString + return $ DatumHash bs + +-- | Generator for Plutus `validatorHash` type. +validatorHash :: Gen ValidatorHash +validatorHash = do + bs <- builtinByteString + return $ ValidatorHash bs diff --git a/src/Apropos/Gen/Time.hs b/src/Apropos/Gen/Time.hs new file mode 100644 index 0000000..fce0caa --- /dev/null +++ b/src/Apropos/Gen/Time.hs @@ -0,0 +1,33 @@ +{- | +Module: Apropos.Gen.Time +Description: Plutus POSIX time generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Time` types. +-} +module Apropos.Gen.Time (posixTimeRange, posixTime) where + +import Apropos.Gen (Gen) +import Apropos.Gen.Extra (integer) +import Apropos.Gen.Interval (interval) +import Apropos.Gen.Range (Range) +import Plutus.V1.Ledger.Time (POSIXTime (POSIXTime), POSIXTimeRange) + +-- | Function for producing `POSIXTimeRange` generators. +posixTimeRange :: + -- | `Range` you wish for the lower bound to take. + Range -> + -- | `Range` you wish for the upper bound to take. + Range -> + -- | A generator for a `POSIXTimeRange`. + Gen POSIXTimeRange +posixTimeRange rL rU = do + let lGen :: Gen POSIXTime = posixTime rL + uGen :: Gen POSIXTime = posixTime rU + interval lGen uGen + +-- | Function for producing `POSIXTime` generators. +posixTime :: Range -> Gen POSIXTime +posixTime r = do + n <- integer r + return $ POSIXTime n diff --git a/src/Apropos/Gen/TxId.hs b/src/Apropos/Gen/TxId.hs new file mode 100644 index 0000000..9a0b012 --- /dev/null +++ b/src/Apropos/Gen/TxId.hs @@ -0,0 +1,18 @@ +{- | +Module: Apropos.Gen.TxId +Description: Plutus `TxId` generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.TxId` types. +-} +module Apropos.Gen.TxId (txId) where + +import Apropos.Gen (Gen) +import Apropos.Gen.Api (builtinByteString) +import Plutus.V1.Ledger.Api (TxId (TxId)) + +-- | Generator for Plutus `TxId` type. +txId :: Gen TxId +txId = do + bs <- builtinByteString + return $ TxId bs diff --git a/src/Apropos/Gen/Value.hs b/src/Apropos/Gen/Value.hs new file mode 100644 index 0000000..054437f --- /dev/null +++ b/src/Apropos/Gen/Value.hs @@ -0,0 +1,65 @@ +{- | +Module: Apropos.Gen.Value +Description: Plutus value generators. +Maintainer: jack@mlabs.city + +`Gen`s for `Plutus.V1.Ledger.Value` types. +-} +module Apropos.Gen.Value ( + ada, + value, + valueWithAda, + currencySymbol, + tokenName, +) where + +import Apropos.Gen (Gen, linear) +import Apropos.Gen.Api (builtinByteString) +import Apropos.Gen.Extra (integer) +import Apropos.Gen.Extra qualified as Gen (map) +import Apropos.Gen.Range (Range) +import Plutus.V1.Ledger.Value ( + CurrencySymbol (CurrencySymbol), + TokenName (TokenName), + Value (Value), + unionWith, + ) +import PlutusTx.AssocMap (Map) +import PlutusTx.AssocMap qualified as AssocMap (singleton) + +-- | Generator for some amount of Ada +ada :: Range -> Gen Value +ada r = do + n <- integer r + let m :: Map CurrencySymbol (Map TokenName Integer) = + AssocMap.singleton (CurrencySymbol "") $ + AssocMap.singleton (TokenName "") n + return $ Value m + +-- | Generator for a Plutus `Value`. +value :: Gen Value +value = do + let tnvMap = Gen.map (linear 1 5) tokenName $ integer (linear 1 maxBound) + v <- Gen.map (linear 1 5) currencySymbol tnvMap + return $ Value v + +{- | Generator for a Plutus `Value`. Guaranteed to contain some + Ada. +-} +valueWithAda :: Gen Value +valueWithAda = do + v <- value + a <- ada $ linear 1 1000 + return $ unionWith (+) v a + +-- | Generator for a Plutus `CurrencySymbol`. +currencySymbol :: Gen CurrencySymbol +currencySymbol = do + bs <- builtinByteString + return $ CurrencySymbol bs + +-- | Generator for a Plutus `TokenName`. +tokenName :: Gen TokenName +tokenName = do + bs <- builtinByteString + return $ TokenName bs