Add AsData functionalities

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

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"
 

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 <command> [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."

plutus-asdata/Setup.hs

@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain

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

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)

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

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)