Completely change API to declarative DSL and implement Plutarch trans…

…piler

Changes:

* Completely change API to declarative DSL (closes mlabs-haskell#24 mlabs-haskell#81, part of mlabs-haskell#29)
* Implement Plutarch transpiler (closes mlabs-haskell#48 mlabs-haskell#79, part of mlabs-haskell#50)
* Support lifting Plutus functions to declarative DSL (closes mlabs-haskell#68)
* Compilation pass changing all error messages to codes
  and saving their correspondence to table
* Remove `Stages` concept altogeter (see issue mlabs-haskell#92)

.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

@@ -28,6 +28,7 @@ common common-lang
 
   build-depends:
     , base
+    , containers
     , mtl
     , transformers
 
@@ -41,9 +42,10 @@ common common-lang
     GADTs
     LambdaCase
     NoImplicitPrelude
-    NoPolyKinds
+    OverloadedRecordDot
     OverloadedStrings
     PatternSynonyms
+    PolyKinds
     QuantifiedConstraints
     StrictData
     TemplateHaskell
@@ -98,11 +100,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
@@ -114,7 +117,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
 
@@ -129,6 +135,7 @@ library cardano-extras
   build-depends:   template-haskell
   exposed-modules:
     Cardano.Extras
+    Plutarch.Extras
     Plutus.Deriving
     Plutus.Extras
 
@@ -141,6 +148,7 @@ library
   exposed-modules:
     Cardano.CEM
     Cardano.CEM.Documentation
+    Cardano.CEM.DSL
     Cardano.CEM.Examples.Auction
     Cardano.CEM.Examples.Compilation
     Cardano.CEM.Examples.Voting
@@ -149,7 +157,6 @@ library
     Cardano.CEM.Monads.L1
     Cardano.CEM.OffChain
     Cardano.CEM.OnChain
-    Cardano.CEM.Stages
     Cardano.CEM.Testing.StateMachine
     Cardano.CEM.TH
 

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 constructors of ADT.
@@ -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,9 +150,7 @@ deriveSpine name = do
   let
     suffix = "Spine"
     spineName = addSuffix name suffix
-  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show]
-  -- TODO: derive Sing
-  -- TODO: derive HasField (OfSpine ...)
+  spineDec <- deriveTags name suffix [''Eq, ''Ord, ''Enum, ''Show, ''Bounded]
 
   decls <-
     [d|
@@ -98,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