Updated to the most recent Alonzo specification

Completed Figures 1, 2, 3, 4, 5, 6, 7, 8 and 12.

alonzo/impl/cardano-ledger-alonzo.cabal

@@ -38,7 +38,8 @@ library
     deepseq,
     nothunks,
     shelley-spec-ledger,
-    small-steps
+    small-steps,
+    text
   hs-source-dirs:
     src
   ghc-options:
@@ -58,6 +59,7 @@ library test
     Test.Cardano.Ledger.Alonzo.Serialisation.Generators
   build-depends:
     base >=4.14 && <4.15,
+    base16-bytestring,
     cardano-crypto-class,
     cardano-ledger-alonzo,
     cardano-ledger-shelley-ma-test,
@@ -87,6 +89,7 @@ test-suite tests
   build-depends:
     base >=4.14 && <4.15,
     bytestring,
+    base16-bytestring,
     cardano-binary,
     cardano-ledger-alonzo,
     cardano-ledger-shelley-ma-test,

alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs

@@ -1,37 +1,82 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Cardano.Ledger.Alonzo.Data
-  ( Data (..),
+  ( PlutusData (..),
+    -- Figure 2 (partial list)
+    Data (Data, ..),
     EraIndependentData,
     DataHash (..),
     hashData,
   )
 where
 
-import Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import Cardano.Binary (FromCBOR (..), ToCBOR (..), decodeInt, encodeInt)
 import qualified Cardano.Crypto.Hash as Hash
 import Cardano.Ledger.Crypto (HASH)
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era (Crypto, Era)
 import Control.DeepSeq (NFData)
 import Data.Coders
+import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Shelley.Spec.Ledger.Hashing (HashAnnotated (..))
 
--- | TODO this should be isomorphic to the plutus (alonzo version) type
-data Data era = NotReallyData
-  deriving (Eq, Ord, Generic, Show)
+-- =====================================================================
+-- PlutusData is a placeholder for the type that Plutus expects as data.
+
+data PlutusData = NotReallyData
+  deriving (Eq, Show, Ord, Generic)
+
+instance NoThunks PlutusData
+
+-- | TODO appropriate serialisation for the Real Plutus Data
+instance ToCBOR (PlutusData) where
+  toCBOR _ = encodeInt 0
+
+instance FromCBOR (PlutusData) where
+  fromCBOR = do
+    i <- decodeInt
+    case i of
+      0 -> pure NotReallyData
+      _ -> fail "oh no"
+
+instance FromCBOR (Annotator PlutusData) where
+  fromCBOR = pure <$> fromCBOR
+
+-- ============================================================================
+-- the newtype Data is a wrapper around the type that Plutus expects as data.
+-- The newtype will memoize the serialized bytes. The strategy is to replace
+-- PlutusData  with the correct type
+
+newtype Data era = DataConstr (MemoBytes (PlutusData))
+  deriving (Eq, Ord, Generic, ToCBOR, Show)
+
+deriving via
+  (Mem PlutusData)
+  instance
+    (Era era) =>
+    FromCBOR (Annotator (Data era))
 
 instance NoThunks (Data era)
 
+pattern Data :: PlutusData -> Data era
+pattern Data p <-
+  DataConstr (Memo p _)
+  where
+    Data p = DataConstr (memoBytes (To p))
+
+-- =============================================================================
+
 data EraIndependentData
 
 newtype DataHash crypto
@@ -53,15 +98,3 @@ hashData = DataHash . hashAnnotated
 --------------------------------------------------------------------------------
 -- Serialisation
 --------------------------------------------------------------------------------
-
--- | TODO appropriate serialisation
-instance Era era => ToCBOR (Data era) where
-  toCBOR = encode . encodeData
-    where
-      encodeData NotReallyData = Sum NotReallyData 0
-
-instance Era era => FromCBOR (Data era) where
-  fromCBOR = decode $ Summands "Data" decodeData
-    where
-      decodeData 0 = SumD NotReallyData
-      decodeData n = Invalid n

alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs

@@ -4,9 +4,12 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
@@ -24,6 +27,9 @@ module Cardano.Ledger.Alonzo.PParams
     PParamsUpdate,
     emptyPParamsUpdate,
     updatePParams,
+    EraIndependentPP,
+    HashTuple (..),
+    hashLanguagePP,
   )
 where
 
@@ -34,6 +40,7 @@ import Cardano.Binary
     encodeListLen,
     encodeMapLen,
     encodeWord,
+    serialize',
   )
 import qualified Cardano.Crypto.Hash as Hash
 import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), Language, Prices (..))
@@ -42,12 +49,16 @@ import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
+import Control.SetAlgebra (eval, (◁))
+import Data.ByteString (ByteString)
 import Data.Foldable (fold)
 import Data.Functor.Identity (Identity)
 import Data.List (nub)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Proxy
+import Data.Set (singleton)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 import Numeric.Natural (Natural)
@@ -75,6 +86,7 @@ import Shelley.Spec.Ledger.Serialization
   )
 import Shelley.Spec.Ledger.Slot (EpochNo (..))
 
+-- ================================================================
 -- TODO
 -- make type families for PParams and PParamsUpdate
 -- what is the encodeListLen ??
@@ -401,6 +413,9 @@ updatePParams pp ppup =
     fromMaybe' :: a -> StrictMaybe a -> a
     fromMaybe' x = fromMaybe x . strictMaybeToMaybe
 
+-- ===================================================
+-- Figure 1: "Definitions Used in Protocol Parameters"
+
 data EraIndependentPP
 
 -- Hash of a subset of Protocol Parameters relevant to Plutus script evaluation
@@ -413,3 +428,39 @@ newtype PPHash crypto
 deriving newtype instance CC.Crypto crypto => FromCBOR (PPHash crypto)
 
 deriving newtype instance CC.Crypto crypto => ToCBOR (PPHash crypto)
+
+hashLanguagePP :: forall era. Era era => PParams era -> Language -> PPHash (Crypto era)
+hashLanguagePP pp lang = PPHash (hash2P (Proxy @EraIndependentPP) (Proxy @era) [HashItem restrictedmap])
+  where
+    restrictedmap :: Map.Map Language CostModel
+    restrictedmap = eval (singleton lang ◁ (_costmdls pp))
+
+-- ===============================================================
+-- Hashing Tuples (upto to width 4) in a uniform way
+
+data HashItem where
+  HashItem :: ToCBOR a => a -> HashItem
+
+serializeHashTuple :: [HashItem] -> ByteString
+serializeHashTuple xs = mconcat (map f xs)
+  where
+    f (HashItem x) = serialize' x
+
+-- Hash with 2 Proxys. This function is only used internally
+-- The type families need alot of help keeping things straight,
+-- the Proxys (and the type signature) provide that help.
+
+hash2P :: forall t e. Era e => Proxy t -> Proxy e -> [HashItem] -> Hash.Hash (CC.HASH (Crypto e)) t
+hash2P _ _ x = Hash.castHash (Hash.hashWith serializeHashTuple x)
+
+class Era e => HashTuple e t where
+  hashTuple :: Proxy e -> t -> Hash.Hash (CC.HASH (Crypto e)) t
+
+instance (Era e, ToCBOR a, ToCBOR b) => HashTuple e (a, b) where
+  hashTuple p (x, y) = hash2P Proxy p [HashItem x, HashItem y]
+
+instance (Era e, ToCBOR a, ToCBOR b, ToCBOR c) => HashTuple e (a, b, c) where
+  hashTuple p (x, y, z) = hash2P Proxy p [HashItem x, HashItem y, HashItem z]
+
+instance (Era e, ToCBOR a, ToCBOR b, ToCBOR c, ToCBOR d) => HashTuple e (a, b, c, d) where
+  hashTuple p (w, x, y, z) = hash2P Proxy p [HashItem w, HashItem x, HashItem y, HashItem z]

alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -13,7 +13,7 @@ module Cardano.Ledger.Alonzo.Scripts
     Script (..),
     ExUnits (..),
     CostModel,
-    Language,
+    Language (..),
     Prices (..),
   )
 where
@@ -75,7 +75,10 @@ instance Semigroup ExUnits where
 instance Monoid ExUnits where
   mempty = ExUnits 0 0
 
--- Script language
+-- Non-Native Script language.
+-- This is an open type. We will add values of this type
+-- for each Non-Native scripting language as they are added.
+
 newtype Language = Language ByteString
   deriving (Eq, Generic, Show, Ord)
 
@@ -160,3 +163,7 @@ instance
       decodeScript 0 = Ann (SumD NativeScript) <*! From
       decodeScript 1 = Ann (SumD PlutusScript)
       decodeScript n = Invalid n
+
+-- =================================================
+-- Languages
+-- =================================================