[PLT-9056] Pretty instance for ScriptDecodeError

plutus-core/executables/pir/README.md

@@ -1,4 +1,4 @@
-A small tool to help with rapid interation when working with Plutus IR compiler.
+A small tool to help with rapid interaction when working with Plutus IR compiler.
 
 For instance, when debugging an issue when compiling a file from the `marlowe`
 package, we can:

plutus-ledger-api/plutus-ledger-api.cabal

@@ -151,6 +151,7 @@ test-suite plutus-ledger-api-test
     Spec.Eval
     Spec.Interval
     Spec.NoThunks
+    Spec.ScriptDecodeError
     Spec.V1.Value
     Spec.Versions
 
@@ -167,6 +168,7 @@ test-suite plutus-ledger-api-test
     , plutus-core:{plutus-core, plutus-core-testlib}                    ^>=1.21
     , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}  ^>=1.21
     , plutus-tx:{plutus-tx, plutus-tx-testlib}                          ^>=1.21
+    , prettyprinter
     , serialise
     , tasty
     , tasty-hedgehog

plutus-ledger-api/src/Codec/CBOR/Extras.hs

@@ -1,70 +1,92 @@
--- editorconfig-checker-disable-file
-{-# LANGUAGE LambdaCase #-}
-module Codec.CBOR.Extras
-    ( SerialiseViaFlat (..)
-    , decodeViaFlat
-    , DeserialiseFailureInfo (..)
-    , DeserialiseFailureReason (..)
-    , readDeserialiseFailureInfo
-    ) where
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
 
-import Codec.CBOR.Decoding as CBOR
-import Codec.CBOR.Read as CBOR
+module Codec.CBOR.Extras (
+  SerialiseViaFlat (..),
+  decodeViaFlat,
+  DeserialiseFailureInfo (..),
+  DeserialiseFailureReason (..),
+  readDeserialiseFailureInfo,
+) where
+
+import Codec.CBOR.Decoding qualified as CBOR
+import Codec.CBOR.Read qualified as CBOR
 import Codec.Serialise (Serialise, decode, encode)
-import Data.Either.Extras
+import Data.Either.Extras (fromRightM)
 import Flat qualified
 import Flat.Decoder qualified as Flat
+import Prettyprinter (Pretty (pretty), (<+>))
 
--- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance that
--- just encodes the flat-serialized value as a CBOR bytestring
+{- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance
+  that just encodes the flat-serialized value as a CBOR bytestring
+-}
 newtype SerialiseViaFlat a = SerialiseViaFlat a
-instance Flat.Flat a => Serialise (SerialiseViaFlat a) where
+
+instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where
   encode (SerialiseViaFlat a) = encode $ Flat.flat a
   decode = SerialiseViaFlat <$> decodeViaFlat Flat.decode
 
 decodeViaFlat :: Flat.Get a -> CBOR.Decoder s a
 decodeViaFlat decoder = do
-    bs <- decodeBytes
-    -- lift any flat's failures to be cborg failures (MonadFail)
-    fromRightM (fail . show) $
-        Flat.unflatWith decoder bs
+  bs <- CBOR.decodeBytes
+  -- lift any flat's failures to be cborg failures (MonadFail)
+  fromRightM (fail . show) $ Flat.unflatWith decoder bs
 
-{- | The errors returned by `cborg` are plain strings (untyped). With this function we try to
-map onto datatypes, those cborg error messages that we are interested in.
+{- | The errors returned by `cborg` are plain strings (untyped). With this
+function we try to map onto datatypes, those cborg error messages that we are
+interested in.
 
-Currently we are only interested in error messages returned by the `CBOR.decodeBytes` decoder;
+Currently we are only interested in error messages returned by the
+`CBOR.decodeBytes` decoder;
 see `PlutusLedgerApi.Common.SerialisedScript.scriptCBORDecoder`.
 -}
 readDeserialiseFailureInfo :: CBOR.DeserialiseFailure -> DeserialiseFailureInfo
 readDeserialiseFailureInfo (CBOR.DeserialiseFailure byteOffset reason) =
-    DeserialiseFailureInfo byteOffset $ interpretReason reason
-  where
-    -- Note that this is subject to change if `cborg` dependency changes. Currently: cborg-0.2.9.0
-    interpretReason :: String -> DeserialiseFailureReason
-    interpretReason = \case
-        -- Relevant Sources:
-        -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L226>
-        -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1424>
-        -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1441>
-        "end of input"   -> EndOfInput
-        -- Relevant Sources:
-        -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1051>
-        "expected bytes" -> ExpectedBytes
-        msg              -> OtherReason msg
+  DeserialiseFailureInfo byteOffset $ interpretReason reason
+ where
+  -- Note that this is subject to change if `cborg` dependency changes.
+  -- Currently: cborg-0.2.9.0
+  interpretReason :: String -> DeserialiseFailureReason
+  interpretReason = \case
+    -- Relevant Sources:
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L226>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1424>
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1441>
+    "end of input" -> EndOfInput
+    -- Relevant Sources:
+    -- <https://github.com/well-typed/cborg/blob/cborg-0.2.9.0/cborg/src/Codec/CBOR/Read.hs#L1051>
+    "expected bytes" -> ExpectedBytes
+    msg -> OtherReason msg
 
--- | Similar to `CBOR.DeserialiseFailure`, with the difference that plain string reason
--- messages are turned into the datatype: `DeserialiseFailureReason`.
-data DeserialiseFailureInfo
-    = DeserialiseFailureInfo
-        { dfOffset :: CBOR.ByteOffset
-        , dfReason :: DeserialiseFailureReason
-        }
-    deriving stock (Eq, Show)
+{- | Similar to `CBOR.DeserialiseFailure`, with the difference that plain
+string reason messages are turned into the datatype: `DeserialiseFailureReason`.
+-}
+data DeserialiseFailureInfo = DeserialiseFailureInfo
+  { dfOffset :: CBOR.ByteOffset
+  , dfReason :: DeserialiseFailureReason
+  }
+  deriving stock (Eq, Show)
+
+instance Pretty DeserialiseFailureInfo where
+  pretty (DeserialiseFailureInfo offset reason) =
+    "CBOR deserialisation failed at the offset"
+      <+> pretty offset
+      <+> "for the following reason:"
+      <+> pretty reason
 
 -- | The reason of the cbor failure as a datatype, not as a plain string.
 data DeserialiseFailureReason
-    = EndOfInput -- ^ Not enough input provided
-    | ExpectedBytes -- ^ The bytes inside the input are malformed.
-    | OtherReason String -- ^ A failure reason we (plutus) are not aware of, use whatever
-                         -- message that `cborg` returns.
-    deriving stock (Eq, Show)
+  = -- | Not enough input provided
+    EndOfInput
+  | -- | The bytes inside the input are malformed.
+    ExpectedBytes
+  | -- | A failure reason we (plutus) are not aware of, use whatever
+    -- message that `cborg` returns.
+    OtherReason String
+  deriving stock (Eq, Show)
+
+instance Pretty DeserialiseFailureReason where
+  pretty = \case
+    EndOfInput -> "reached the end of input while more data was expected."
+    ExpectedBytes -> "the bytes inside the input are malformed."
+    OtherReason msg -> pretty msg

plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs

@@ -45,7 +45,6 @@ import Data.Set as Set
 import Data.Text as Text
 import Data.Tuple
 import NoThunks.Class
-import Prettyprinter
 
 -- | Errors that can be thrown when evaluating a Plutus script.
 data EvaluationError =
@@ -63,7 +62,7 @@ instance AsScriptDecodeError EvaluationError where
 instance Pretty EvaluationError where
     pretty (CekError e)               = prettyClassicDef e
     pretty (DeBruijnError e)          = pretty e
-    pretty (CodecError e)             = viaShow e
+    pretty (CodecError e)             = pretty e
     pretty CostModelParameterMismatch = "Cost model parameters were not as we expected"
 
 -- | A simple toggle indicating whether or not we should accumulate logs during script execution.
@@ -100,7 +99,8 @@ mkTermToEvaluate ll pv script args = do
 
     -- check that the Plutus Core language version is available
     -- See Note [Checking the Plutus Core language version]
-    unless (v `Set.member` plcVersionsAvailableIn ll pv) $ throwing _ScriptDecodeError $ PlutusCoreLanguageNotAvailableError v pv
+    unless (v `Set.member` plcVersionsAvailableIn ll pv) $
+      throwing _ScriptDecodeError $ PlutusCoreLanguageNotAvailableError v ll pv
 
     -- make sure that term is closed, i.e. well-scoped
     through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT

plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs

@@ -1,6 +1,9 @@
-{-# LANGUAGE DeriveAnyClass  #-}
-{-# LANGUAGE DerivingVia     #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DerivingVia       #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module PlutusLedgerApi.Common.SerialisedScript (
   SerialisedScript,
@@ -39,7 +42,7 @@ import Control.Lens
 import Control.Monad (unless, when)
 import Control.Monad.Error.Lens
 import Control.Monad.Except (MonadError)
-import Data.ByteString.Lazy as BSL (ByteString, fromStrict, toStrict)
+import Data.ByteString.Lazy qualified as BSL
 import Data.ByteString.Short
 import Data.Coerce
 import Data.Set as Set
@@ -65,7 +68,9 @@ data ScriptDecodeError
       }
   | PlutusCoreLanguageNotAvailableError
       { sdeAffectedVersion :: !UPLC.Version
-      -- ^ the script's Plutus Core language version
+      -- ^ the Plutus Core language of the script under execution.
+      , sdeThisLang        :: !PlutusLedgerLanguage
+      -- ^ the Plutus ledger language of the script under execution.
       , sdeThisPv          :: !MajorProtocolVersion
       -- ^ the current protocol version
       }
@@ -74,6 +79,30 @@ data ScriptDecodeError
 
 makeClassyPrisms ''ScriptDecodeError
 
+instance Pretty ScriptDecodeError where
+  pretty = \case
+    CBORDeserialiseError e ->
+      "Failed to deserialise a script:" <+> pretty e
+    RemainderError bs ->
+      "Script was successfully deserialised, but"
+        <+> pretty (BSL.length bs)
+        <+> "more bytes were encountered after the script's position."
+    LedgerLanguageNotAvailableError{..} ->
+      "Your script has a Plutus Ledger Language version of"
+        <+> pretty sdeAffectedLang <> "."
+        <+> "This is not yet supported by the current major protocol version"
+        <+> pretty sdeThisPv <> "."
+        <+> "The major protocol version that introduces \
+            \this Plutus Ledger Language is"
+        <+> pretty sdeIntroPv <> "."
+    PlutusCoreLanguageNotAvailableError{..} ->
+      "Your script has a Plutus Core version of"
+        <+> pretty sdeAffectedVersion <> "."
+        <+> "This is not supported in"
+        <+> pretty sdeThisLang
+        <+> "and major protocol version"
+        <+> pretty sdeThisPv <> "."
+
 {- Note [Size checking of constants in PLC programs]
 We impose a 64-byte *on-the-wire* limit on the constants inside PLC programs. This prevents
 people from inserting Mickey Mouse entire.
@@ -217,7 +246,7 @@ deserialiseScript ll pv sScript = do
     deserialiseSScript :: SerialisedScript -> m (BSL.ByteString, ScriptNamedDeBruijn)
     deserialiseSScript =
       fromShort
-        >>> fromStrict
+        >>> BSL.fromStrict
         >>> CBOR.deserialiseFromBytes (scriptCBORDecoder ll pv)
         -- lift the underlying cbor error to our custom error
         >>> either (throwing _ScriptDecodeError . toScripDecodeError) pure

plutus-ledger-api/test/Spec.hs

@@ -12,6 +12,7 @@ import Spec.CostModelParams qualified
 import Spec.Eval qualified
 import Spec.Interval qualified
 import Spec.NoThunks qualified
+import Spec.ScriptDecodeError qualified
 import Spec.V1.Value qualified as Value
 import Spec.Versions qualified
 
@@ -106,6 +107,7 @@ tests = testGroup "plutus-ledger-api"[
     , Spec.CostModelParams.tests
     , Spec.NoThunks.tests
     , Spec.CBOR.DeserialiseFailureInfo.tests
+    , Spec.ScriptDecodeError.tests
     , Spec.ContextDecoding.tests
     , Value.test_Value
     ]

plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs

@@ -1,29 +1,73 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes      #-}
-module Spec.CBOR.DeserialiseFailureInfo (tests)
-where
 
-import Codec.CBOR.Decoding as CBOR
-import Codec.CBOR.Extras as CBOR
-import Codec.CBOR.Read as CBOR
+module Spec.CBOR.DeserialiseFailureInfo (tests) where
+
+import Codec.CBOR.Decoding qualified as CBOR
+import Codec.CBOR.Extras qualified as CBOR
+import Codec.CBOR.Read qualified as CBOR
 
 import Data.Bifunctor
 import Data.ByteString.Lazy qualified as LBS
-import Test.Tasty
-import Test.Tasty.HUnit
+import Prettyprinter (Pretty, pretty)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@=?), (@?=))
 
 tests :: TestTree
-tests = testGroup "cbor failure intepretation tests"
-     [ testCase "end-of-input" $
-         (CBOR.decodeBytes `failsWith` CBOR.EndOfInput) []
-     , testCase "expected-bytes" $
-         (CBOR.decodeBytes `failsWith` CBOR.ExpectedBytes) [0x5c]
-     , testCase "other" $
-         (CBOR.decodeBool `failsWith` CBOR.OtherReason "expected bool") [0x5c]
-     ]
-  where
-    failsWith :: (Eq a, Show a)
-              => (forall s. Decoder s a) -> DeserialiseFailureReason -> LBS.ByteString -> Assertion
-    failsWith decoder reason inp =
-        let res = CBOR.deserialiseFromBytes decoder inp
-        in Left reason @=? first (CBOR.dfReason . readDeserialiseFailureInfo) res
+tests =
+  testGroup
+    "cbor failure"
+    [ testGroup
+        "intepretation tests"
+        [ testCase "end-of-input"
+            $ (CBOR.decodeBytes `failsWith` CBOR.EndOfInput) []
+        , testCase "expected-bytes"
+            $ (CBOR.decodeBytes `failsWith` CBOR.ExpectedBytes) [0x5c]
+        , testCase "other"
+            $ (CBOR.decodeBool `failsWith` CBOR.OtherReason "expected bool") [0x5c]
+        ]
+    , testGroup
+        "pretty-printing"
+        [ testCase "end-of-input"
+            $ renderPretty
+              CBOR.DeserialiseFailureInfo
+                { CBOR.dfOffset = 123425678900000
+                , CBOR.dfReason = CBOR.EndOfInput
+                }
+            @?= "CBOR deserialisation failed at the offset 123425678900000 \
+                \for the following reason: reached the end of input \
+                \while more data was expected."
+        , testCase "expected-bytes"
+            $ renderPretty
+              CBOR.DeserialiseFailureInfo
+                { CBOR.dfOffset = 123425678900000
+                , CBOR.dfReason = CBOR.ExpectedBytes
+                }
+            @?= "CBOR deserialisation failed at the offset 123425678900000 \
+                \for the following reason: \
+                \the bytes inside the input are malformed."
+        , testCase "other"
+            $ let reason = "expected bool"
+               in renderPretty
+                    CBOR.DeserialiseFailureInfo
+                      { CBOR.dfOffset = 123425678900000
+                      , CBOR.dfReason = CBOR.OtherReason reason
+                      }
+                    @?= "CBOR deserialisation failed at the offset 123425678900000 \
+                        \for the following reason: "
+                    <> reason
+        ]
+    ]
+ where
+  failsWith ::
+    (Eq a, Show a) =>
+    (forall s. CBOR.Decoder s a) ->
+    CBOR.DeserialiseFailureReason ->
+    LBS.ByteString ->
+    Assertion
+  failsWith decoder reason inp =
+    let res = CBOR.deserialiseFromBytes decoder inp
+     in Left reason @=? first (CBOR.dfReason . CBOR.readDeserialiseFailureInfo) res
+
+  renderPretty :: (Pretty a) => a -> String
+  renderPretty = show . pretty