Introduced the intermediate type LangDepView which is different for e…

…very Language.

Added the type synonym PPHash for SafeHash LangDepView.

alonzo/impl/cardano-ledger-alonzo.cabal

@@ -22,6 +22,7 @@ library
   exposed-modules:
     Cardano.Ledger.Alonzo
     Cardano.Ledger.Alonzo.Data
+     Cardano.Ledger.Alonzo.Language
     Cardano.Ledger.Alonzo.PParams
     Cardano.Ledger.Alonzo.Scripts
     Cardano.Ledger.Alonzo.Tx

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

@@ -15,23 +15,26 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -- | This module contains just the type of protocol parameters.
 module Cardano.Ledger.Alonzo.PParams
   ( PParams' (..),
     PParams,
-    PPHash,
     emptyPParams,
     ProtVer (..),
     ProposedPPUpdates (..),
     emptyPPPUpdates,
     PParamsUpdate,
     emptyPParamsUpdate,
     updatePParams,
-    hashLanguagePP,
+    getLanguageView,
+    LangDepView(..),
+    PPHash,
   )
 where
 
+import Data.Kind(Type)
 import Cardano.Binary
   ( Annotator,
     Decoder,
@@ -41,28 +44,27 @@ import Cardano.Binary
     encodeListLen,
     encodeMapLen,
     encodeWord,
+    encodePreEncoded,
   )
 import Cardano.Ledger.Alonzo.Scripts
   ( CostModel,
     ExUnits (..),
-    Language,
     Prices (..),
-    hashCostModel,
   )
+import Cardano.Ledger.Alonzo.Language(Language(..))
 import Cardano.Ledger.Era
-import Cardano.Ledger.SafeHash (SafeHash)
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
-import Data.Coders (Decode (..), decode, (<*!))
+import Data.Coders (Decode (..), Encode(..), Wrapped(..), decode, (!>), (<*!))
+import Data.ByteString.Short (fromShort)
 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 GHC.Generics (Generic)
-import NoThunks.Class (NoThunks (..))
+import NoThunks.Class (NoThunks (..), InspectHeapNamed(..))
 import Numeric.Natural (Natural)
 import Shelley.Spec.Ledger.BaseTypes
   ( Nonce (NeutralNonce),
@@ -87,6 +89,14 @@ import Shelley.Spec.Ledger.Serialization
     ratioToCBOR,
   )
 import Shelley.Spec.Ledger.Slot (EpochNo (..))
+import Data.MemoBytes(MemoBytes(..), memoBytes)
+import Data.Typeable
+import Cardano.Ledger.SafeHash
+   ( SafeToHash(..),
+     HashWithCrypto(..),
+     EraIndependentPParamView,
+     SafeHash,
+   )
 
 -- ================================================================
 -- TODO
@@ -428,15 +438,74 @@ updatePParams pp ppup =
 -- ===================================================
 -- Figure 1: "Definitions Used in Protocol Parameters"
 
--- Hash of a subset of Protocol Parameters relevant to Plutus script evaluation
-type PPHash crypto = SafeHash crypto CostModel
+-- The Language Depenedent View type (LangDepView) is a GADT, it will have a different
+-- Constructor for each Language. This way each language can have a different
+-- view of the Protocol parameters. This is an intermediate type and we introduce
+-- it only because we are interested in its hash. Thus is has to be a type
+-- that remembers its original bytes. We make it a data type around a MemoBytes.
+-- Unfortunately we can't use a newtype, because the constructor must existentially
+-- hide the Language index. Instance on GADT's are a bit tricky so we are carefull
+-- in the comments below to explain them. Because we intend to add new languages
+-- the GADT will someday end up with more constructors. So we add some commented
+-- out code that suggests how to extend the instances when that happens.
+
+data RawView:: Type -> Language -> Type where
+    RawPlutusView ::  CostModel -> RawView era 'PlutusV1
+ -- RawOtherView :: Int -> RawView era 'OtherLANG
+
+deriving instance Eq (RawView era lang)
+deriving instance Ord (RawView era lang)
+deriving instance Show (RawView era lang)
+deriving instance Typeable (RawView era lang)
+deriving via InspectHeapNamed "RawView" (RawView e l) instance NoThunks (RawView e l)
+
+instance (Typeable era) => ToCBOR (LangDepView era) where
+  toCBOR (LangDepViewConstr (Memo _ bytes)) = encodePreEncoded (fromShort bytes)
+
+pattern PlutusView :: CostModel -> LangDepView era
+pattern PlutusView cm <- LangDepViewConstr (Memo (RawPlutusView cm) _)
+  where PlutusView cm = LangDepViewConstr (memoBytes (Sum RawPlutusView 0 !> To cm))
+                                                      -- Note the tag 0 ^
+{- How to extend to another language
+pattern OtherView :: Int -> LangDepView era
+pattern OtherView n <- LangDepViewConstr (Memo (RawOtherView cm) _)
+  where OtherView n = LangDepViewConstr (memoBytes (Sum RawOtherView 1 !> To n))
+                                                  -- Note the tag 1  ^
+-}
+
+{-# COMPLETE PlutusView {- OtherView -}  #-}
+
+instance (Typeable era) => FromCBOR (Annotator (LangDepView era)) where
+   fromCBOR = decode $ Summands "LangDepView" decodeTag
+    where
+      decodeTag :: Word -> Decode 'Open (Annotator(LangDepView era))
+      decodeTag 0 = Ann (SumD PlutusView) <*! From
+          -- Since CostModel has only (FromCBOR (Annotator CostModel) insatnce
+   -- decodeTag 1 = Ann (SumD OtherView) <*! (Ann From)
+          -- Since Int has FromCBOR instance
+      decodeTag n = Invalid n
 
-hashLanguagePP :: forall era. Era era => PParams era -> Language -> PPHash (Crypto era)
-hashLanguagePP pp lang = (hashCostModel (Proxy @era) cm)
-  where
-    cm :: CostModel
-    cm = case Map.lookup lang (_costmdls pp) of
-      Just x -> x
-      Nothing -> error ("CostModel map does not have cost for language: " ++ show lang)
+data LangDepView era where
+    LangDepViewConstr:: (MemoBytes (RawView era lang)) -> LangDepView era
+
+-- We can't derive SafeToHash via newtype deriving because LandDepViewConstr is a data
+-- not a newtype. But it does remember its original bytes so we can add the instance.
+
+instance SafeToHash (LangDepView era) where
+   originalBytes (LangDepViewConstr (Memo _ bs)) = fromShort bs
+
+instance HashWithCrypto (LangDepView era) EraIndependentPParamView
+
+deriving via InspectHeapNamed "LangDepView" (LangDepView e) instance NoThunks (LangDepView e)
+
+instance Show (LangDepView era) where
+    show (PlutusView x) = show x
+
+type PPHash crypto = SafeHash crypto EraIndependentPParamView
 
--- =============================================================
+getLanguageView :: forall era. Era era =>
+  PParams era -> Language -> SafeHash (Crypto era) EraIndependentPParamView
+getLanguageView pp PlutusV1 =
+    case Map.lookup PlutusV1 (_costmdls pp) of
+      Just x -> hashWithCrypto (Proxy @(Crypto era)) (PlutusView x)
+      Nothing -> error ("CostModel map does not have cost for language: " ++ show PlutusV1)

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

@@ -19,7 +19,6 @@ module Cardano.Ledger.Alonzo.Scripts
     Script (..),
     ExUnits (..),
     CostModel (CostModel),
-    Language (..),
     Prices (..),
     hashCostModel,
   )
@@ -88,21 +87,6 @@ instance Semigroup ExUnits where
 instance Monoid ExUnits where
   mempty = ExUnits 0 0
 
--- 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)
-
-instance NoThunks Language
-
-instance NFData Language
-
-deriving instance ToCBOR Language
-
-deriving instance FromCBOR Language
-
 -- =====================================
 -- Cost Model needs to preserve its serialization bytes as
 -- it is going to be hashed. Thus we make it a newtype around a MemoBytes
@@ -206,7 +190,3 @@ instance
       decodeScript 0 = Ann (SumD NativeScript) <*! From
       decodeScript 1 = Ann (SumD PlutusScript)
       decodeScript n = Invalid n
-
--- =================================================
--- Languages
--- =================================================

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

@@ -29,7 +29,7 @@ module Cardano.Ledger.Alonzo.Tx
     -- Figure 1
     CostModel,
     PPHash,
-    hashLanguagePP,
+    getLanguageView,
     -- Figure 2
     ScriptData,
     ScriptDataHash,
@@ -38,8 +38,6 @@ module Cardano.Ledger.Alonzo.Tx
     IsValidating (..),
     hashData,
     language,
-    plutusLanguage,
-    timelockLanguage,
     nonNativeLanguages,
     hashScriptData,
     getCoin,
@@ -79,8 +77,9 @@ where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Data (Data, DataHash, hashData)
-import Cardano.Ledger.Alonzo.PParams (PPHash, PParams, PParams' (..), hashLanguagePP)
-import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), Language (..), Prices (..))
+import Cardano.Ledger.Alonzo.PParams (PPHash, PParams, PParams' (..), getLanguageView)
+import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), Prices (..))
+import Cardano.Ledger.Alonzo.Language (Language (..), nonNativeLanguages)
 import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..), Tag (..))
 import Cardano.Ledger.Alonzo.TxBody
   ( AlonzoBody,
@@ -121,14 +120,11 @@ import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
   ( elemAt,
-    empty,
     findIndex,
-    insert,
     map,
     null,
     union,
   )
-import Data.Text.Encoding (encodeUtf8)
 import Data.Typeable (Typeable)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -302,22 +298,6 @@ deriving via
 -- =========================================================
 -- Figure 2: Definitions for Transactions
 
--- For now, the only Non-Native Scriting language is Plutus
--- We might add new languages in the futures.
-
-nonNativeLanguages :: Set Language
-nonNativeLanguages = Set.insert plutusLanguage Set.empty
-
-plutusLanguage :: Language
-plutusLanguage = Language (encodeUtf8 "Plutus")
-
-timelockLanguage :: Language
-timelockLanguage = Language (encodeUtf8 "Timelock")
-
-language :: AlonzoScript.Script era -> Language
-language (AlonzoScript.NativeScript _) = timelockLanguage
-language (AlonzoScript.PlutusScript) = plutusLanguage
-
 getCoin :: UsesValue era => TxOut era -> Coin
 getCoin (TxOut _ v _) = coin v
 
@@ -402,7 +382,7 @@ hashScriptData pp langs rdmrs =
   if Map.null rdmrs && Set.null langs
     then Nothing
     else
-      let newset = Set.map (hashLanguagePP pp) langs
+      let newset = Set.map (getLanguageView pp) langs
        in Just (hashAnnotated (WitnessLangData rdmrs newset))
 
 -- ===============================================================
@@ -609,9 +589,15 @@ collectNNScriptInputs _pp tx utxo =
     | (sp, scripthash) <- scriptsNeeded utxo tx, -- TODO, IN specification ORDER IS WRONG
       (d, eu) <- maybeToList (indexedRdmrs tx sp),
       script <- maybeToList (Map.lookup scripthash (txscripts (txwits tx))),
-      cost <- maybeToList (Map.lookup (language script) (_costmdls _pp))
+      cost <- case (language script) of
+                Nothing -> []
+                Just lang -> maybeToList (Map.lookup lang (_costmdls _pp))
   ]
 
+language :: AlonzoScript.Script era -> Maybe Language
+language (AlonzoScript.NativeScript _) = Nothing
+language (AlonzoScript.PlutusScript) = Just PlutusV1
+
 evalScripts :: (AlonzoScript.Script era, [Data era], ExUnits, CostModel) -> Bool
 evalScripts (AlonzoScript.NativeScript _timelock, _, _, _) = True
 evalScripts (AlonzoScript.PlutusScript, ds, units, cost) = b

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

@@ -41,7 +41,6 @@ where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Alonzo.Data (DataHash)
-import Cardano.Ledger.Alonzo.PParams (PPHash)
 import Cardano.Ledger.Alonzo.Scripts (ExUnits)
 import Cardano.Ledger.Alonzo.TxWitness (ScriptDataHash)
 import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
@@ -84,6 +83,7 @@ import Shelley.Spec.Ledger.Delegation.Certificates (DCert)
 import Shelley.Spec.Ledger.PParams (Update)
 import Shelley.Spec.Ledger.TxBody (TxIn (..), Wdrl (Wdrl), unWdrl)
 import Prelude hiding (lookup)
+import Cardano.Ledger.Alonzo.PParams(PPHash)
 
 -- | Tag indicating whether an input should be used to pay transaction fees.
 -- This is used to prevent the entirety of a script's inputs being used for fees
@@ -425,6 +425,7 @@ instance
           mempty
           SNothing
           SNothing
+      bodyFields :: (Word -> Field (TxBodyRaw era))
       bodyFields 0 =
         field
           (\x tx -> tx {_inputs = x})