diff --git a/specification/Diagrams.hs b/specification/Diagrams.hs new file mode 100644 index 0000000..b009f20 --- /dev/null +++ b/specification/Diagrams.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Concurrent (forkIO) +import Control.Monad (forM_) +import Data.GraphViz + ( GraphvizCanvas (Xlib), + GraphvizOutput (Canon, DotOutput, Svg), + runGraphviz, + runGraphvizCanvas', + ) +import Family +import Family.Diagram + ( OverlayMode (Distinct, Parallel, Serial), + combineTransactionGraphs, + transactionGraphToDot, + transactionTypeGraph, + ) +import Family.Diagram.TH (diagramForTransactionType, untypedDiagramForTransactionType) +import qualified Language.Haskell.TH as TH +-- import the transaction instances +import qualified Spec + +-- transaction diagrams +listing = $([t|'Spec.Listing "Alice" "BTC"|] >>= untypedDiagramForTransactionType) + +underlying = $([t|'Spec.UnderlyingMint "Alice" "UTxORef" "token_name" |] >>= untypedDiagramForTransactionType) + +-- rendering +main = do + let listingGraph = transactionTypeGraph listing + underlyingGraph = transactionTypeGraph underlying + dots = transactionGraphToDot "diagram" <$> [listingGraph, underlyingGraph] + distinct = transactionGraphToDot "distinct" $ + combineTransactionGraphs Distinct [listingGraph, underlyingGraph] + parallel = transactionGraphToDot "parallel" $ + combineTransactionGraphs Parallel [listingGraph, underlyingGraph] + serial = transactionGraphToDot "serial" $ + combineTransactionGraphs Serial [listingGraph, underlyingGraph] + forM_ ([distinct, parallel, serial] <> dots) $ \dot -> do + forkIO (runGraphvizCanvas' dot Xlib) + runGraphviz dot Svg "diagram.svg" diff --git a/specification/Spec.hs b/specification/Spec.hs new file mode 100644 index 0000000..5f3b334 --- /dev/null +++ b/specification/Spec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Spec where + +import Data.Kind (Type) +import Data.Void (Void) +import Family +import GHC.TypeLits (Symbol) +import Numeric.Natural (Natural) + +data TransactionFamily + = UnderlyingMint Symbol Symbol Symbol + | MintWrap + | ChangePrice + | ChangeOwner + | UnwrapBurn + | Listing Symbol Symbol + +data SeaBug + = MainMintingPolicy + | LockingValidator Symbol Natural Natural + | MarketplaceValidator + | NftMint Symbol + +type instance DApp (t :: TransactionFamily) = SeaBug + +type instance Economy SeaBug = Token + +data Token + = Ada + | UnderlyingNFT Underlying + | SGNFT SeabugNFT + +data SeabugNFT = SeabugNFT Symbol + +data Underlying = Underlying Symbol Symbol + +-- * Minting policies + +data MainMintRedeemer = MainMintRedeemer Symbol Natural Symbol + +instance MintingPolicyScript 'MainMintingPolicy where + type MintedToken 'MainMintingPolicy = SeabugNFT + type MintRedeemer 'MainMintingPolicy = MainMintRedeemer + +instance MintingPolicyScript ('NftMint txoutRef) where + type MintedToken ('NftMint txoutRef) = Underlying + type MintRedeemer ('NftMint txoutRef) = () + +-- * Validators + +data LockDatum (s :: Symbol) (m :: Natural) (n :: Natural) = LockDatum + +instance ValidatorScript ('LockingValidator s m n) where + type Datum ('LockingValidator s m n) = LockDatum s m n + type Redeemer ('LockingValidator s m n) = Void + +data MarketplaceDatum = MarketplaceDatum + +instance ValidatorScript 'MarketplaceValidator where + type Datum 'MarketplaceValidator = MarketplaceDatum + type Redeemer 'MarketplaceValidator = () + +-- * Transactions + +type ListingInputs :: Symbol -> Symbol -> InputsFor SeaBug +data ListingInputs user ac script wallet = ListingInputs + { nft :: wallet user 'Nothing '[ 'Exactly 1 ('SGNFT ('SeabugNFT ac)), 'MinimumRequiredAda ] + } + +type ListingOutputs :: Symbol -> Symbol -> OutputsFor SeaBug +data ListingOutputs user ac script wallet = ListingOutputs + { marketplace :: script 'MarketplaceValidator 'MarketplaceDatum '[ 'Exactly 1 ('SGNFT ('SeabugNFT ac)), 'MinimumRequiredAda ] + } + +instance Transaction (Listing user ac) where + type Inputs (Listing user ac) = ListingInputs user ac + type Outputs (Listing user ac) = ListingOutputs user ac + +type UnderlyingInputs :: Symbol -> InputsFor SeaBug +data UnderlyingInputs utxoRef script wallet = UnderlyingInputs + { utxo :: wallet utxoRef 'Nothing '[ AnythingElse ] + } + +type UnderlyingMints :: Symbol -> Symbol -> MintsFor SeaBug +data UnderlyingMints utxoRef tokenName mp = UnderlyingMints + { mintedNFT :: mp ('NftMint utxoRef) '() '[ 'Mint 1 ('Underlying utxoRef tokenName) ] + } + +type UnderlyingOutputs :: Symbol -> Symbol -> Symbol -> OutputsFor SeaBug +data UnderlyingOutputs user utxoRef tokenName script wallet = UnderlyingOutputs + { utxo :: wallet utxoRef 'Nothing '[ 'AnythingElse ] + , nft :: wallet user 'Nothing '[ 'Exactly 1 (UnderlyingNFT ('Underlying utxoRef tokenName)), 'MinimumRequiredAda ] + } + +instance Transaction (UnderlyingMint user utxoRef tokenName) where + type Inputs (UnderlyingMint user utxoRef tokenName) = UnderlyingInputs utxoRef + type Mints (UnderlyingMint user utxoRef tokenName) = UnderlyingMints utxoRef tokenName + type Outputs (UnderlyingMint user utxoRef tokenName) = UnderlyingOutputs user utxoRef tokenName diff --git a/specification/diagram.svg b/specification/diagram.svg new file mode 100644 index 0000000..b308d9d --- /dev/null +++ b/specification/diagram.svg @@ -0,0 +1,83 @@ + + + + + + + +diagram + +cluster_7 + +UTxORef's wallet + + +cluster_15 + +Alice's wallet + + + +3 + +AnythingElse + + + +0 + + +UnderlyingMint Alice UTxORef token_name + + + +3->0 + + +utxo + + + +12 + +AnythingElse + + + +4 + +Exactly 1 UnderlyingNFT Underlying UTxORef token_name +MinimumRequiredAda + + + +0->12 + + +utxo + + + +0->4 + + +nft + + + +5 + +NftMint UTxORef + + + +0->5 + + +() @ mint 1 Underlying UTxORef token_name + + + diff --git a/specification/specification.cabal b/specification/specification.cabal new file mode 100644 index 0000000..73b7328 --- /dev/null +++ b/specification/specification.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +name: specification +version: 0.1.0.0 +author: MLabs + +executable diagrams + main-is: Diagrams.hs + ghc-options: -ddump-splices -ddump-to-file + default-language: Haskell2010 + other-modules: + Spec + build-depends: + , base >=4.15 && <5 + , containers + , template-haskell >= 2.17 + , text + , graphviz >= 2999.10 + , transaction-family-specification == 0.1.*