diff --git a/cabal.project b/cabal.project index c4388e9b..5dba560a 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,7 @@ index-state: 2021-10-20T00:00:00Z packages: + ./plutus-asdata/plutus-asdata.cabal ./plutus-extra/plutus-extra.cabal ./tasty-plutus/tasty-plutus.cabal ./plutus-pretty/plutus-pretty.cabal diff --git a/hie.yaml b/hie.yaml index 4023d1e6..82f05b5d 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,5 +1,8 @@ cradle: cabal: + - path: "./plutus-asdata/src" + component: "lib:plutus-asdata" + - path: "./plutus-collection/src" component: "lib:plutus-collection" @@ -9,6 +12,9 @@ cradle: - path: "./plutus-collection/test/size" component: "plutus-collection:test:plutus-collection-size" + - path: "./plutus-context-builder/src" + component: "lib:plutus-context-builder" + - path: "./plutus-deriving/src" component: "lib:plutus-deriving" diff --git a/plutus-asdata/Makefile b/plutus-asdata/Makefile new file mode 100644 index 00000000..58b649b9 --- /dev/null +++ b/plutus-asdata/Makefile @@ -0,0 +1,120 @@ +# The plutus-pab commands, contracts and hoogle environment +# 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 + +usage: + @echo "usage: make [OPTIONS]" + @echo + @echo "Available options:" + @echo " FLAGS -- Additional options passed to --ghc-options" + @echo + @echo "Available commands:" + @echo " hoogle -- Start local hoogle" + @echo " build -- Run cabal v2-build" + @echo " watch -- Track files and run 'make build' on change" + @echo " test -- Run cabal v2-test" + @echo " costing -- Run cost-estimation benchmark" + @echo " coverage -- Generate a coverage report of the tests" + @echo " ghci -- Run stack ghci" + @echo " format -- Apply source code formatting with fourmolu" + @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 " lint -- Check the sources with hlint" + @echo " refactor -- Automatically apply hlint refactors, with prompt + @echo " readme_contents -- Add table of contents to README" + @echo " update_plutus -- Update plutus version with niv" + +hoogle: requires_nix_shell + hoogle server --local + +STACK_EXE_PATH = $(shell stack $(STACK_FLAGS) path --local-install-root)/bin + +ifdef FLAGS +GHC_FLAGS = --ghc-options "$(FLAGS)" +endif + +build: requires_nix_shell plutus-extra.cabal + cabal v2-build $(GHC_FLAGS) + +watch: requires_nix_shell plutus-extra.cabal + while sleep 1; do find plutus-extra.cabal src test | entr -cd make build; done + +test: requires_nix_shell plutus-extra.cabal + cabal v2-test + +ghci: requires_nix_shell plutus-extra.cabal + cabal v2-repl $(GHC_FLAGS) + +coverage: plutus-extra.cabal + nix-build --arg doCoverage true -A projectCoverageReport + +# Source dirs to run fourmolu on +FORMAT_SOURCES := $(shell find -name '*.hs' -not -path './dist-*/*') + +# Extensions we need to tell fourmolu about +FORMAT_EXTENSIONS := -o -XTemplateHaskell -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -fplugin=RecordDotPreprocessor + +# Run fourmolu formatter +format: requires_nix_shell + fourmolu --mode inplace --check-idempotence $(FORMAT_EXTENSIONS) $(FORMAT_SOURCES) + +# Check formatting (without making changes) +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' ) + +cabalfmt: requires_nix_shell + cd .. ; cabal-fmt --inplace $(CABAL_SOURCES) + +cabalfmt_check: requires_nix_shell + cd .. ; cabal-fmt --check $(CABAL_SOURCES) + +# Nix files to format +NIX_SOURCES := $(shell git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.nix$$' ) + +nixfmt: requires_nix_shell + cd .. ; nixfmt $(NIX_SOURCES) + +nixfmt_check: requires_nix_shell + cd .. ; nixfmt --check $(NIX_SOURCES) + +# Check with hlint, currently I couldn't get --refactor to work +lint: requires_nix_shell + hlint $(FORMAT_SOURCES) + +# Apply automatic hlint refactors, with prompt +refactor: requires_nix_shell + for src in $(FORMAT_SOURCES) ; do hlint --refactor --refactor-options='-i -s' $$src ; done + +readme_contents: + echo "this command is not nix-ified, you may receive an error from npx" + npx markdown-toc ./README.md --no-firsth1 + +# Target to use as dependency to fail if not inside nix-shell +requires_nix_shell: + @ [ -v IN_NIX_SHELL ] || echo "The $(MAKECMDGOALS) target must be run from inside nix-shell" + @ [ -v IN_NIX_SHELL ] || (echo " run 'nix-shell --pure' first" && false) + + +PLUTUS_BRANCH = $(shell jq '.plutus.branch' ./nix/sources.json ) +PLUTUS_REPO = $(shell jq '.plutus.owner + "/" + .plutus.repo' ./nix/sources.json ) +PLUTUS_REV = $(shell jq '.plutus.rev' ./nix/sources.json ) +PLUTUS_SHA256 = $(shell jq '.plutus.sha256' ./nix/sources.json ) + +update_plutus: + @echo "Updating plutus version to latest commit at $(PLUTUS_REPO) $(PLUTUS_BRANCH)" + niv update plutus + @echo "Latest commit: $(PLUTUS_REV)" + @echo "Sha256: $(PLUTUS_SHA256)" + @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." diff --git a/plutus-asdata/Setup.hs b/plutus-asdata/Setup.hs new file mode 100644 index 00000000..e8ef27db --- /dev/null +++ b/plutus-asdata/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/plutus-asdata/plutus-asdata.cabal b/plutus-asdata/plutus-asdata.cabal new file mode 100644 index 00000000..e74e00c5 --- /dev/null +++ b/plutus-asdata/plutus-asdata.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.0 +name: plutus-asdata +version: 1.0 +extra-source-files: CHANGELOG.md + +common lang + default-language: Haskell2010 + default-extensions: + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NumericUnderscores + OverloadedStrings + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + TypeSynonymInstances + UndecidableInstances + + build-depends: base ^>=4.14 + ghc-options: + -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints + -Wmissing-export-lists -Werror -Wincomplete-record-updates + -Wmissing-deriving-strategies + +library + import: lang + exposed-modules: + PlutusTx.AsData + + build-depends: + , plutus-ledger + , plutus-ledger-api + , plutus-tx + , template-haskell >=2.14 && <= 2.19 + , th-abstraction ^>=0.3 + + hs-source-dirs: src diff --git a/plutus-asdata/src/PlutusTx/AsData.hs b/plutus-asdata/src/PlutusTx/AsData.hs new file mode 100644 index 00000000..d0616e7a --- /dev/null +++ b/plutus-asdata/src/PlutusTx/AsData.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TemplateHaskell #-} + +module PlutusTx.AsData where + +import Data.Kind (Type) +import Ledger ( + Address, + Datum, + PubKeyHash, + ScriptContext, + TxId, + TxInInfo, + TxInfo, + TxOut, + TxOutRef, + Value, + ) +import Ledger.Typed.Scripts (WrappedValidatorType) +import PlutusTx ( + ToData (toBuiltinData), + UnsafeFromData (unsafeFromBuiltinData), + ) +import PlutusTx.AsData.Internal (AsData (AsData)) +import PlutusTx.AsData.Internal.TH (mkAsDataAccessors) +import PlutusTx.Prelude +import Prelude () + +{-# INLINEABLE safeFromData #-} +safeFromData :: UnsafeFromData x => AsData x -> x +safeFromData (AsData d) = unsafeFromBuiltinData d + +{-# INLINEABLE safeToData #-} +safeToData :: ToData x => x -> AsData x +safeToData x = AsData $ toBuiltinData x + +{-# INLINEABLE unsafeInjectData #-} +unsafeInjectData :: BuiltinData -> AsData x +unsafeInjectData = AsData + +{-# INLINEABLE forgetData #-} +forgetData :: AsData x -> BuiltinData +forgetData (AsData d) = d + +{-# INLINEABLE inefficientMapData #-} +inefficientMapData :: (UnsafeFromData x, ToData y) => (x -> y) -> AsData x -> AsData y +inefficientMapData f x = safeToData $ f $ safeFromData x + +mkAsDataAccessors ''ScriptContext +mkAsDataAccessors ''TxInfo +mkAsDataAccessors ''TxInInfo +mkAsDataAccessors ''TxOut +mkAsDataAccessors ''TxOutRef +mkAsDataAccessors ''TxId +mkAsDataAccessors ''Address +mkAsDataAccessors ''Value +mkAsDataAccessors ''PubKeyHash +mkAsDataAccessors ''Datum + +{-# INLINEABLE toTypedValidator #-} +toTypedValidator :: + forall (d :: Type) (r :: Type). + (ToData d, ToData r) => + (AsData d -> AsData r -> AsData ScriptContext -> Bool) -> + (d -> r -> ScriptContext -> Bool) +toTypedValidator f d r sc = f (safeToData d) (safeToData r) (safeToData sc) + +{-# INLINEABLE toWrappedValidator #-} +toWrappedValidator :: + forall (d :: Type) (r :: Type). + (AsData d -> AsData r -> AsData ScriptContext -> Bool) -> + WrappedValidatorType +toWrappedValidator f d r sc = check $ f (unsafeInjectData d) (unsafeInjectData r) (unsafeInjectData sc) diff --git a/plutus-asdata/src/PlutusTx/AsData/Internal.hs b/plutus-asdata/src/PlutusTx/AsData/Internal.hs new file mode 100644 index 00000000..169b3bac --- /dev/null +++ b/plutus-asdata/src/PlutusTx/AsData/Internal.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RoleAnnotations #-} + +module PlutusTx.AsData.Internal (AsData (AsData)) where + +import Data.Kind (Type) +import PlutusTx (BuiltinData) + +type role AsData representational +newtype AsData (x :: Type) = AsData BuiltinData diff --git a/plutus-asdata/src/PlutusTx/AsData/Internal/TH.hs b/plutus-asdata/src/PlutusTx/AsData/Internal/TH.hs new file mode 100644 index 00000000..b814a738 --- /dev/null +++ b/plutus-asdata/src/PlutusTx/AsData/Internal/TH.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskell #-} + +module PlutusTx.AsData.Internal.TH (mkAsDataAccessors) where + +import Language.Haskell.TH ( + Body (NormalB), + Clause (Clause), + Dec (FunD, PragmaD, SigD), + Exp (VarE), + Inline (Inlinable), + Name, + Pat (ListP, VarP, WildP), + Phases (AllPhases), + Pragma (InlineP), + Q, + RuleMatch (FunLike), + Type (ConT), + mkName, + nameBase, + newName, + ) +import Language.Haskell.TH.Datatype ( + ConstructorInfo (constructorFields, constructorVariant), + ConstructorVariant (RecordConstructor), + DatatypeInfo (datatypeCons), + reifyDatatype, + ) +import Plutus.V1.Ledger.Api (BuiltinData (BuiltinData), Data (Constr)) +import PlutusTx.AsData.Internal (AsData (AsData)) +import PlutusTx.Prelude qualified as P + +mkAsDataAccessors :: Name -> Q [Dec] +mkAsDataAccessors dtName = do + dtInfo <- reifyDatatype dtName + case datatypeCons dtInfo of + [singleCon] + | RecordConstructor fieldNames <- constructorVariant singleCon -> + let fieldTypes = constructorFields singleCon + fields = zip3 [0 ..] fieldNames fieldTypes + size = length fields + in concat <$> traverse (genSingleAccessor (ConT dtName) size) fields + _ -> pure [] + +genSingleAccessor :: Type -> Int -> (Int, Name, Type) -> Q [Dec] +genSingleAccessor dt size (pos, fieldName, ty) = do + let name = mkName $ nameBase fieldName + let inlineable = PragmaD (InlineP name Inlinable FunLike AllPhases) + funTy <- [t|AsData $(pure dt) -> AsData $(pure ty)|] + let sig = SigD name funTy + x <- newName "x" + pat <- [p|AsData (BuiltinData (Constr 0 $(pure $ ListP $ makePats x size pos)))|] + ex <- [|AsData (BuiltinData $(pure $ VarE x))|] + let normalClause = Clause [pat] (NormalB ex) [] + err <- [|P.traceError "AsData: malformed AsData value."|] + let impossibleClause = Clause [WildP] (NormalB err) [] + let dec = FunD name [normalClause, impossibleClause] + pure [inlineable, sig, dec] + where + makePats :: Name -> Int -> Int -> [Pat] + makePats _ 0 _ = [] + makePats x s p + | p == 0 = VarP x : makePats x (s - 1) (p - 1) + | otherwise = WildP : makePats x (s - 1) (p - 1)