Merge branch 'master' into alexey/test-oura-filters

Author: euonymos

.ghcid

@@ -1 +1 @@
---command="cabal repl test-suite:cem-sdk-test" -W -T ":main --failure-report=/tmp/hspec-report.txt -r"
+--command="cabal repl test-suite:cem-sdk-test" -W -T ":main"

.hlint.yaml

@@ -16,3 +16,4 @@
 - ignore: {name: Use unless}
 - ignore: {name: "Use asks"}
 - ignore: {name: "Eta reduce"}
+- ignore: {name: Use concatMap}

cem-script.cabal

@@ -37,6 +37,7 @@ common common-lang
   build-depends:
     , base
     , extra
+    , containers
     , mtl
     , transformers
 
@@ -50,9 +51,10 @@ common common-lang
     GADTs
     LambdaCase
     NoImplicitPrelude
-    NoPolyKinds
+    OverloadedRecordDot
     OverloadedStrings
     PatternSynonyms
+    PolyKinds
     QuantifiedConstraints
     StrictData
     TemplateHaskell
@@ -104,11 +106,12 @@ common common-offchain
     , cardano-ledger-babbage
     , cardano-ledger-core
     , cardano-ledger-shelley
-    , containers
     , filepath
     , ouroboros-network-protocols
     , pretty-show
+    , prettyprinter
     , retry
+    , singletons-th
     , text
     , time
     , unix
@@ -120,7 +123,10 @@ common common-executable
 library data-spine
   import:          common-lang
   hs-source-dirs:  src-lib/data-spine
+
+  -- FIXME: was not meant to be dependent on Plutus...
   build-depends:
+    , plutus-tx
     , singletons
     , template-haskell
 
@@ -135,6 +141,7 @@ library cardano-extras
   build-depends:   template-haskell
   exposed-modules:
     Cardano.Extras
+    Plutarch.Extras
     Plutus.Extras
 
 library
@@ -147,6 +154,7 @@ library
     Cardano.CEM
     Cardano.CEM.Address
     Cardano.CEM.Documentation
+    Cardano.CEM.DSL
     Cardano.CEM.Examples.Auction
     Cardano.CEM.Examples.Compilation
     Cardano.CEM.Examples.Voting

docs/catalyst_milestone_reports.md

@@ -10,16 +10,31 @@
 * Final code clean-up
 * Final tutorial and docs
 
+## Clarifications on M3 Deliverables
+
+### Running an Emulated Environment by CLB
+
+The CLB monad is designed to interact seamlessly with a Cardano mockchain environment. It can read from a shared environment, query blockchain parameters such as the current slot, and retrieve UTXO information, among other functions. This module facilitates simulation and testing, making it essential for unit tests and other testing scenarios where a controlled blockchain environment is needed. Using this emulated environment, developers can test and validate their Cardano applications in a reliable and repeatable manner.
+
+### Running QuickCheck Dynamic Tests, Including Mutation Support
+
+QuickCheck is a powerful Haskell library for property-based testing, which helps ensure that programs behave correctly for a wide range of inputs. The quickcheck-dynamic library extends this tool to stateful systems, making it particularly suitable for testing blockchain applications. Our testing framework uses a state machine model to simulate real-world scenarios, incorporating support for mutation testing. This approach helps verify that the system maintains correct behavior under various conditions, including edge cases and unexpected changes, thereby enhancing the robustness of the application.
+
+### Rendering CEMScript State Graphs
+
+Understanding state transitions and the overall system flow is critical for ensuring blockchain applications do not enter invalid states. To aid developers, we have implemented automated rendering of state graphs through our documentation module. This module generates DOT graph representations of CEMScript state transitions, providing an easy-to-understand visual model of how a DApp functions in real-world scenarios. This visualization tool increases developer confidence by highlighting the system's behavior and identifying potential shortcomings.
+
 # Milestone 4
 
 ## Summary
 
 Catalyst Milestone Outputs:
 
-* Plutarch on-chain code generation and optimisation ([PR](https://github.com/mlabs-haskell/cem-script/pull/94))
+* Static DSL for constraints and Plutarch on-chain code generation and optimisation ([PR#96](https://github.com/mlabs-haskell/cem-script/pull/96))
 * Profiling implementation ([PR](https://github.com/mlabs-haskell/cem-script/pull/95))
 * Profiling performed for old (using Plutus) and new (using Plutarch) code generator.
   New one showed advantage over first one in all fees measured, and in some cases in order of magntude.
+* A [video](https://www.youtube.com/watch?v=wveLyvuKjeI) that summarizes the outcomes achieved in the milestone.
 
 ## Profiling results
 

docs/tech_debt.md

@@ -0,0 +1,9 @@
+* Design
+  * Tx Signers
+  * Tx stuff naming
+* Tests
+  * Mutation and security
+* Code arch and style
+  * No onchain/offchain GHC options separations of code
+  * No hlint
+* CI and versioning

src-lib/cardano-extras/Plutarch/Extras.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE QualifiedDo #-}
+
+module Plutarch.Extras where
+
+import Prelude
+
+import Plutarch
+import Plutarch.Builtin
+import Plutarch.LedgerApi
+import Plutarch.LedgerApi.Value
+import Plutarch.Maybe (pfromJust)
+import Plutarch.Monadic qualified as P
+import Plutarch.Prelude
+
+pMkAdaOnlyValue :: Term s (PInteger :--> PValue Unsorted NonZero)
+pMkAdaOnlyValue = phoistAcyclic $ plam $ \lovelaces ->
+  pforgetSorted $
+    psingletonData # padaSymbolData # pdata padaToken # pdata lovelaces
+
+pscriptHashAddress :: Term s (PAsData PScriptHash :--> PAddress)
+pscriptHashAddress = plam $ \datahash ->
+  let credential = pcon (PScriptCredential (pdcons @"_0" # datahash #$ pdnil))
+      nothing = pdata $ pcon (PDNothing pdnil)
+      inner = pdcons @"credential" # pdata credential #$ pdcons @"stakingCredential" # nothing #$ pdnil
+   in pcon (PAddress inner)
+
+ppkhAddress :: Term s (PAsData PPubKeyHash :--> PAddress)
+ppkhAddress = plam $ \datahash ->
+  let credential = pcon (PPubKeyCredential (pdcons @"_0" # datahash #$ pdnil))
+      nothing = pdata $ pcon (PDNothing pdnil)
+      inner = pdcons @"credential" # pdata credential #$ pdcons @"stakingCredential" # nothing #$ pdnil
+   in pcon (PAddress inner)
+
+getOwnAddress :: ClosedTerm (PAsData PScriptContext :--> PAsData PAddress)
+getOwnAddress = phoistAcyclic $ plam $ \ctx -> P.do
+  PSpending outRef' <- pmatch $ pfromData $ pfield @"purpose" # ctx
+  pfield @"address"
+    #$ pfield @"resolved"
+    #$ pfromJust
+    #$ (pfindOwnInput # (pfield @"inputs" #$ pfield @"txInfo" # ctx))
+    #$ pfield @"_0"
+    # outRef'

src-lib/data-spine/Data/Spine.hs

@@ -3,13 +3,29 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE PolyKinds #-}
 
-module Data.Spine (HasSpine (..), deriveSpine, OfSpine (..)) where
+{- |
+Note about design decision on nested spines.
+`getSpine (Just Value) = JustSpine ValueSpine` - looks more usable,
+than `getSpine (Just Value) = JustSpine`.
+But it seem to break deriving for parametised types like `Maybe a`,
+and can be done with `fmap getSpine mValue`. Probably it actually
+works exaclty for functorial parameters.
+-}
+module Data.Spine where
 
 import Prelude
 
+import Data.Data (Proxy)
+import Data.List (elemIndex)
+import Data.Map qualified as Map
+import Data.Maybe (mapMaybe)
+import GHC.Natural (Natural)
+import GHC.TypeLits (KnownSymbol, symbolVal)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 
+import PlutusTx (FromData, ToData, UnsafeFromData, unstableMakeIsData)
+
 -- | Definitions
 
 {- | Spine is datatype, which tags only constructors of ADT skipping their content.
@@ -19,29 +35,66 @@ import Language.Haskell.TH.Syntax
 class
   ( Ord (Spine sop)
   , Show (Spine sop)
+  , Enum (Spine sop)
+  , Bounded (Spine sop)
   ) =>
   HasSpine sop
   where
-  type Spine sop
+  type Spine sop = spine | spine -> sop
   getSpine :: sop -> Spine sop
 
-instance (HasSpine sop1, HasSpine sop2) => HasSpine (sop1, sop2) where
-  type Spine (sop1, sop2) = (Spine sop1, Spine sop2)
-  getSpine (d1, d2) = (getSpine d1, getSpine d2)
+-- | Version of `HasSpine` knowing its Plutus Data encoding
+class
+  ( HasSpine sop
+  , UnsafeFromData sop
+  , ToData sop
+  , FromData sop
+  ) =>
+  HasPlutusSpine sop
+  where
+  fieldsMap :: Map.Map (Spine sop) [String]
+
+toNat :: Int -> Natural
+toNat = fromInteger . toInteger
+
+spineFieldsNum :: forall sop. (HasPlutusSpine sop) => Spine sop -> Natural
+spineFieldsNum spine =
+  toNat $ length $ (fieldsMap @sop) Map.! spine
+
+-- FIXME: use spine do discriminate
+fieldNum ::
+  forall sop label.
+  (HasPlutusSpine sop, KnownSymbol label) =>
+  Proxy label ->
+  Natural
+fieldNum proxyLabel =
+  head $ mapMaybe fieldIndex x
+  where
+    x = Map.elems $ fieldsMap @sop
+    fieldName = symbolVal proxyLabel
+    fieldIndex dict = toNat <$> elemIndex fieldName dict
 
-instance (HasSpine sop) => HasSpine (Maybe sop) where
-  type Spine (Maybe sop) = Maybe (Spine sop)
-  getSpine = fmap getSpine
+allSpines :: forall sop. (HasPlutusSpine sop) => [Spine sop]
+allSpines = [Prelude.minBound .. Prelude.maxBound]
 
--- | Newtype encoding sop value of fixed known spine
-newtype OfSpine (x :: Spine datatype) = UnsafeMkOfSpine {getValue :: datatype}
+-- | Phantom type param is required for `HasSpine` injectivity
+data MaybeSpine a = JustSpine | NothingSpine
+  deriving stock (Eq, Ord, Show, Bounded, Enum)
+
+-- FIXME: could such types be derived?
+instance HasSpine (Maybe x) where
+  type Spine (Maybe x) = MaybeSpine x
+  getSpine Just {} = JustSpine
+  getSpine Nothing = NothingSpine
+
+-- Deriving utils
 
--- | Deriving utils
 addSuffix :: Name -> String -> Name
 addSuffix (Name (OccName name) flavour) suffix =
   Name (OccName $ name <> suffix) flavour
 
-reifyDatatype :: Name -> Q (Name, [Name])
+-- FIXME: cleaner return type
+reifyDatatype :: Name -> Q (Name, [Name], [[Name]])
 reifyDatatype ty = do
   (TyConI tyCon) <- reify ty
   (name, cs :: [Con]) <-
@@ -50,7 +103,17 @@ reifyDatatype ty = do
       NewtypeD _ n _ _ cs _ -> pure (n, [cs])
       _ -> fail "deriveTags: only 'data' and 'newtype' are supported"
   csNames <- mapM consName cs
-  return (name, csNames)
+  csFields <- mapM consFields cs
+  return (name, csNames, csFields)
+  where
+    fieldName (name, _, _) = name
+    consFields (RecC _ fields) = return $ map fieldName fields
+    consFields (NormalC _ fields) | length fields == 0 = return []
+    consFields _ =
+      fail $
+        "Spine: only Sum-of-Products are supported, but "
+          <> show ty
+          <> " is not"
 
 consName :: (MonadFail m) => Con -> m Name
 consName cons =
@@ -61,7 +124,7 @@ consName cons =
 
 deriveTags :: Name -> String -> [Name] -> Q [Dec]
 deriveTags ty suff classes = do
-  (tyName, csNames) <- reifyDatatype ty
+  (tyName, csNames, _) <- reifyDatatype ty
   -- XXX: Quasi-quote splice does not work for case matches list
   let cs = map (\name -> NormalC (addSuffix name suff) []) csNames
       v =
@@ -70,7 +133,7 @@ deriveTags ty suff classes = do
 
 deriveMapping :: Name -> String -> Q Exp
 deriveMapping ty suff = do
-  (_, csNames) <- reifyDatatype ty
+  (_, csNames, _) <- reifyDatatype ty
   -- XXX: Quasi-quote splice does not work for case matches list
   let
     matches =
@@ -87,7 +150,7 @@ deriveSpine name = do
   let
     suffix = "Spine"
     spineName = addSuffix name suffix
-  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show]
+  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show, ''Bounded]
 
   decls <-
     [d|
@@ -96,3 +159,19 @@ deriveSpine name = do
         getSpine = $(deriveMapping name suffix)
       |]
   return $ spineDec <> decls
+
+derivePlutusSpine :: Name -> Q [Dec]
+derivePlutusSpine name = do
+  decls <- deriveSpine name
+  isDataDecls <- unstableMakeIsData name
+
+  (_, _, fieldsNames') <- reifyDatatype name
+  let fieldsNames = map (map nameBase) fieldsNames'
+  instanceDecls <-
+    [d|
+      instance HasPlutusSpine $(conT name) where
+        fieldsMap =
+          Map.fromList $ zip (allSpines @($(conT name))) fieldsNames
+      |]
+
+  return $ decls <> isDataDecls <> instanceDecls