From be0aa252107ddfb2cb03f5b877d07b9aa0186a84 Mon Sep 17 00:00:00 2001 From: Nikolaos Bezirgiannis <329939+bezirg@users.noreply.github.com> Date: Sat, 8 Jun 2024 20:31:22 +0200 Subject: [PATCH] Refactored Serialise/Flat-Via. Fixes #6083 (#6144) Co-authored-by: Nikolaos Bezirgiannis --- .../changelog.d/20240528_112406_bezirg.md | 4 ++ .../executables/plutus/AnyProgram/IO.hs | 2 +- plutus-core/plutus-core.cabal | 3 +- .../src/Codec/Extras/FlatViaSerialise.hs | 40 +++++++++++ .../Extras.hs => Extras/SerialiseViaFlat.hs} | 39 +++++----- .../plutus-core/src/PlutusCore/Flat.hs | 43 +---------- .../UntypedPlutusCore/Core/Instance/Flat.hs | 12 +--- .../Common/SerialisedScript.hs | 9 ++- .../test/Spec/CBOR/DeserialiseFailureInfo.hs | 2 +- .../test/Spec/ScriptDecodeError.hs | 2 +- plutus-tx/src/PlutusTx/Coverage.hs | 71 +++++++++---------- 11 files changed, 111 insertions(+), 116 deletions(-) create mode 100644 plutus-core/changelog.d/20240528_112406_bezirg.md create mode 100644 plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs rename plutus-core/plutus-core/src/Codec/{CBOR/Extras.hs => Extras/SerialiseViaFlat.hs} (71%) diff --git a/plutus-core/changelog.d/20240528_112406_bezirg.md b/plutus-core/changelog.d/20240528_112406_bezirg.md new file mode 100644 index 00000000000..65214cc9f83 --- /dev/null +++ b/plutus-core/changelog.d/20240528_112406_bezirg.md @@ -0,0 +1,4 @@ +### Changed + +- Renamed decodeViaFlat to decodeViaFlatWith +- Renamed AsSerialize to FlatViaSerialise diff --git a/plutus-core/executables/plutus/AnyProgram/IO.hs b/plutus-core/executables/plutus/AnyProgram/IO.hs index 5e61e0ff368..38aabfc7a18 100644 --- a/plutus-core/executables/plutus/AnyProgram/IO.hs +++ b/plutus-core/executables/plutus/AnyProgram/IO.hs @@ -17,7 +17,7 @@ import PlutusCore.Pretty qualified as PP import PlutusPrelude hiding ((%~)) import Types -import Codec.CBOR.Extras +import Codec.Extras.SerialiseViaFlat import Codec.Serialise (deserialiseOrFail, serialise) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 0c6afcd8c47..9158c964044 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -82,7 +82,8 @@ common lang library import: lang exposed-modules: - Codec.CBOR.Extras + Codec.Extras.FlatViaSerialise + Codec.Extras.SerialiseViaFlat Data.Aeson.THReader Data.Either.Extras Data.List.Extras diff --git a/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs new file mode 100644 index 00000000000..b35209c8cd4 --- /dev/null +++ b/plutus-core/plutus-core/src/Codec/Extras/FlatViaSerialise.hs @@ -0,0 +1,40 @@ +module Codec.Extras.FlatViaSerialise + ( FlatViaSerialise (..) + ) where + +import Codec.Serialise (Serialise, deserialiseOrFail, serialise) +import Data.ByteString.Lazy qualified as BSL (toStrict) +import Flat + +{- Note [Flat serialisation for strict and lazy bytestrings] +The `flat` serialisation of a bytestring consists of a sequence of chunks, with each chunk preceded +by a single byte saying how long it is. The end of a serialised bytestring is marked by a +zero-length chunk. In the Plutus Core specification we recommend that all bytestrings should be +serialised in a canonical way as a sequence of zero or more 255-byte chunks followed by an optional +final chunk of length less than 255 followed by a zero-length chunk (ie, a 0x00 byte). We do allow +the decoder to accept non-canonical encodings. The `flat` library always encodes strict Haskell +bytestrings in this way, but lazy bytestrings, which are essentially lists of strict bytestrings, +may be encoded non-canonically since it's more efficient just to emit a short chunk as is. The +Plutus Core `bytestring` type is strict so bytestring values are always encoded canonically. +However, we serialise `Data` objects (and perhaps objects of other types as well) by encoding them +to CBOR and then flat-serialising the resulting bytestring; but the `serialise` method from +`Codec.Serialise` produces lazy bytestrings and if we were to serialise them directly then we could +end up with non-canonical encodings, which would mean that identical `Data` objects might be +serialised into different bytestrings. To avoid this we convert the output of `serialise` into a +strict bytestring before flat-encoding it. This may lead to a small loss of efficiency during +encoding, but this doesn't matter because we only ever do flat serialisation off the chain. We can +convert `Data` objects to bytestrings on the chain using the `serialiseData` builtin, but this +performs CBOR serialisation and the result is always in a canonical form. -} + +-- | For deriving 'Flat' instances via 'Serialize'. +newtype FlatViaSerialise a = FlatViaSerialise { unFlatViaSerialise :: a } + +instance Serialise a => Flat (FlatViaSerialise a) where + -- See Note [Flat serialisation for strict and lazy bytestrings] + encode = encode . BSL.toStrict . serialise . unFlatViaSerialise + decode = do + errOrX <- deserialiseOrFail <$> decode + case errOrX of + Left err -> fail $ show err -- Here we embed a 'Serialise' error into a 'Flat' one. + Right x -> pure $ FlatViaSerialise x + size = size . BSL.toStrict . serialise . unFlatViaSerialise diff --git a/plutus-core/plutus-core/src/Codec/CBOR/Extras.hs b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs similarity index 71% rename from plutus-core/plutus-core/src/Codec/CBOR/Extras.hs rename to plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs index a29ae3751dd..9deb7586f28 100644 --- a/plutus-core/plutus-core/src/Codec/CBOR/Extras.hs +++ b/plutus-core/plutus-core/src/Codec/Extras/SerialiseViaFlat.hs @@ -1,13 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} - -module Codec.CBOR.Extras ( - SerialiseViaFlat (..), - decodeViaFlat, - DeserialiseFailureInfo (..), - DeserialiseFailureReason (..), - readDeserialiseFailureInfo, -) where +module Codec.Extras.SerialiseViaFlat + ( SerialiseViaFlat (..) + , decodeViaFlatWith + , DeserialiseFailureInfo (..) + , DeserialiseFailureReason (..) + , readDeserialiseFailureInfo + ) where import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Read qualified as CBOR @@ -20,14 +19,14 @@ 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 SerialiseViaFlat a = SerialiseViaFlat a +newtype SerialiseViaFlat a = SerialiseViaFlat { unSerialiseViaFlat :: a } instance (Flat.Flat a) => Serialise (SerialiseViaFlat a) where - encode (SerialiseViaFlat a) = encode $ Flat.flat a - decode = SerialiseViaFlat <$> decodeViaFlat Flat.decode + encode = encode . Flat.flat . unSerialiseViaFlat + decode = SerialiseViaFlat <$> decodeViaFlatWith Flat.decode -decodeViaFlat :: Flat.Get a -> CBOR.Decoder s a -decodeViaFlat decoder = do +decodeViaFlatWith :: Flat.Get a -> CBOR.Decoder s a +decodeViaFlatWith decoder = do bs <- CBOR.decodeBytes -- lift any flat's failures to be cborg failures (MonadFail) fromRightM (fail . show) $ Flat.unflatWith decoder bs @@ -45,16 +44,16 @@ 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 + -- Currently: cborg-0.2.10.0 interpretReason :: String -> DeserialiseFailureReason interpretReason = \case -- Relevant Sources: - -- - -- - -- + -- + -- + -- "end of input" -> EndOfInput -- Relevant Sources: - -- + -- "expected bytes" -> ExpectedBytes msg -> OtherReason msg @@ -80,8 +79,8 @@ data DeserialiseFailureReason EndOfInput | -- | The bytes inside the input are malformed. ExpectedBytes - | -- | A failure reason we (plutus) are not aware of, use whatever - -- message that `cborg` returns. + | -- | This is either a cbor failure that we (plutus) are not aware of, + -- or an underlying flat failure. We use whatever message `cborg` or flat returns. OtherReason String deriving stock (Eq, Show) diff --git a/plutus-core/plutus-core/src/PlutusCore/Flat.hs b/plutus-core/plutus-core/src/PlutusCore/Flat.hs index ccc4ea5d813..07223e8af97 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Flat.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Flat.hs @@ -12,17 +12,15 @@ -- encoding of TPLC] and Note [Stable encoding of UPLC] before touching anything -- in this file. module PlutusCore.Flat - ( AsSerialize (..) - , safeEncodeBits + ( safeEncodeBits ) where +import Codec.Extras.FlatViaSerialise import PlutusCore.Core import PlutusCore.Data (Data) import PlutusCore.DeBruijn import PlutusCore.Name.Unique -import Codec.Serialise (Serialise, deserialiseOrFail, serialise) -import Data.ByteString.Lazy qualified as BSL (toStrict) import Data.Proxy import Flat import Flat.Decoder @@ -105,41 +103,6 @@ This phase-1 validation is in place both for normal (locked scripts) and for inl so the nodes' behavior does not change. -} -{- Note [Flat serialisation for strict and lazy bytestrings] -The `flat` serialisation of a bytestring consists of a sequence of chunks, with each chunk preceded -by a single byte saying how long it is. The end of a serialised bytestring is marked by a -zero-length chunk. In the Plutus Core specification we recommend that all bytestrings should be -serialised in a canonical way as a sequence of zero or more 255-byte chunks followed by an optional -final chunk of length less than 255 followed by a zero-length chunk (ie, a 0x00 byte). We do allow -the decoder to accept non-canonical encodings. The `flat` library always encodes strict Haskell -bytestrings in this way, but lazy bytestrings, which are essentially lists of strict bytestrings, -may be encoded non-canonically since it's more efficient just to emit a short chunk as is. The -Plutus Core `bytestring` type is strict so bytestring values are always encoded canonically. -However, we serialise `Data` objects (and perhaps objects of other types as well) by encoding them -to CBOR and then flat-serialising the resulting bytestring; but the `serialise` method from -`Codec.Serialise` produces lazy bytestrings and if we were to serialise them directly then we could -end up with non-canonical encodings, which would mean that identical `Data` objects might be -serialised into different bytestrings. To avoid this we convert the output of `serialise` into a -strict bytestring before flat-encoding it. This may lead to a small loss of efficiency during -encoding, but this doesn't matter because we only ever do flat serialisation off the chain. We can -convert `Data` objects to bytestrings on the chain using the `serialiseData` builtin, but this -performs CBOR serialisation and the result is always in a canonical form. -} - --- | For deriving 'Flat' instances via 'Serialize'. -newtype AsSerialize a = AsSerialize - { unAsSerialize :: a - } deriving newtype (Serialise) - -instance Serialise a => Flat (AsSerialize a) where - -- See Note [Flat serialisation for strict and lazy bytestrings] - encode = encode . BSL.toStrict . serialise - decode = do - errOrX <- deserialiseOrFail <$> decode - case errOrX of - Left err -> fail $ show err -- Here we embed a 'Serialise' error into a 'Flat' one. - Right x -> pure x - size = size . BSL.toStrict . serialise - safeEncodeBits :: NumBits -> Word8 -> Encoding safeEncodeBits maxBits v = if 2 ^ maxBits <= v @@ -156,7 +119,7 @@ encodeConstant = safeEncodeBits constantWidth decodeConstant :: Get Word8 decodeConstant = dBEBits8 constantWidth -deriving via AsSerialize Data instance Flat Data +deriving via FlatViaSerialise Data instance Flat Data decodeKindedUniFlat :: Closed uni => Get (SomeTypeIn (Kinded uni)) decodeKindedUniFlat = diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs index 91421118897..307163b5907 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs @@ -23,6 +23,7 @@ import Data.Vector qualified as V import Flat import Flat.Decoder import Flat.Encoder +import Flat.Encoder.Strict (sizeListWith) import Universe {- @@ -91,17 +92,6 @@ encoding of bytestrings is a sequence of 255-byte chunks. This is okay, since us be broken up by the chunk metadata. -} --- TODO: This is present upstream in newer versions of flat, remove once we get there. --- | Compute the size needed for a list using the given size function for the elements. --- Goes with 'encodeListWith'. -sizeListWith :: (a -> NumBits -> NumBits) -> [a] -> NumBits -> NumBits -sizeListWith sizer = go - where - -- Single bit to say stop - go [] sz = sz + 1 - -- Size for the rest plus size for the element, plus one for a tag to say keep going - go (x:xs) sz = go xs $ sizer x $ sz + 1 - -- | Using 4 bits to encode term tags. termTagWidth :: NumBits termTagWidth = 4 diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs index 249c4a63c73..a17def31f14 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs @@ -32,8 +32,8 @@ import UntypedPlutusCore qualified as UPLC import PlutusCore.DeBruijn.Internal (FakeNamedDeBruijn (FakeNamedDeBruijn)) import Codec.CBOR.Decoding qualified as CBOR -import Codec.CBOR.Extras as CBOR.Extras import Codec.CBOR.Read qualified as CBOR +import Codec.Extras.SerialiseViaFlat as CBOR.Extras import Codec.Serialise import Control.Arrow ((>>>)) import Control.DeepSeq (NFData) @@ -159,9 +159,8 @@ serialiseUPLC = ledger-language-version-specific checks like for allowable builtins. -} uncheckedDeserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -uncheckedDeserialiseUPLC = unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort - where - unSerialiseViaFlat (SerialiseViaFlat (UPLC.UnrestrictedProgram a)) = a +uncheckedDeserialiseUPLC = + UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort -- | A script with named de-bruijn indices. newtype ScriptNamedDeBruijn @@ -212,7 +211,7 @@ scriptCBORDecoder ll pv = in do -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added (p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <- - decodeViaFlat flatDecoder + decodeViaFlatWith flatDecoder pure $ coerce p {- | The deserialization from a serialised script into a `ScriptForEvaluation`, diff --git a/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs b/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs index 9c7efaf87a6..8c1b5059489 100644 --- a/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs +++ b/plutus-ledger-api/test/Spec/CBOR/DeserialiseFailureInfo.hs @@ -4,8 +4,8 @@ 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 Codec.Extras.SerialiseViaFlat qualified as CBOR import Data.Bifunctor import Data.ByteString.Lazy qualified as LBS diff --git a/plutus-ledger-api/test/Spec/ScriptDecodeError.hs b/plutus-ledger-api/test/Spec/ScriptDecodeError.hs index a14c2cab95c..c02c62961ff 100644 --- a/plutus-ledger-api/test/Spec/ScriptDecodeError.hs +++ b/plutus-ledger-api/test/Spec/ScriptDecodeError.hs @@ -2,7 +2,7 @@ module Spec.ScriptDecodeError where -import Codec.CBOR.Extras (DeserialiseFailureInfo (..), DeserialiseFailureReason (..)) +import Codec.Extras.SerialiseViaFlat (DeserialiseFailureInfo (..), DeserialiseFailureReason (..)) import PlutusCore.Version (plcVersion100) import PlutusLedgerApi.Common (ScriptDecodeError (..)) import PlutusLedgerApi.Common.Versions (PlutusLedgerLanguage (..), conwayPV, vasilPV) diff --git a/plutus-tx/src/PlutusTx/Coverage.hs b/plutus-tx/src/PlutusTx/Coverage.hs index 345142fa6d5..dc6984bdf3b 100644 --- a/plutus-tx/src/PlutusTx/Coverage.hs +++ b/plutus-tx/src/PlutusTx/Coverage.hs @@ -1,11 +1,9 @@ --- editorconfig-checker-disable-file -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module PlutusTx.Coverage ( CoverageAnnotation(..) , CoverageIndex(..) @@ -32,9 +30,9 @@ module PlutusTx.Coverage ( CoverageAnnotation(..) import Control.Lens +import Codec.Extras.FlatViaSerialise import Codec.Serialise - -import PlutusCore.Flat +import Flat hiding (to) import Control.DeepSeq import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) @@ -52,8 +50,6 @@ import Prettyprinter import Prelude -import Flat hiding (to) - {- Note [Coverage annotations] During compilation we can insert coverage annotations in `trace` calls in the PIR code that are tracked in the relevant downstream code by looking at @@ -80,7 +76,7 @@ data CovLoc = CovLoc { _covLocFile :: String , _covLocEndCol :: Int } deriving stock (Ord, Eq, Show, Read, Generic) deriving anyclass (Serialise) - deriving Flat via (AsSerialize CovLoc) + deriving Flat via (FlatViaSerialise CovLoc) deriving anyclass (NFData, ToJSON, FromJSON) makeLenses ''CovLoc @@ -93,7 +89,7 @@ data CoverageAnnotation = CoverLocation CovLoc | CoverBool CovLoc Bool deriving stock (Ord, Eq, Show, Read, Generic) deriving anyclass (Serialise) - deriving Flat via (AsSerialize CoverageAnnotation) + deriving Flat via (FlatViaSerialise CoverageAnnotation) deriving anyclass (NFData, ToJSON, FromJSON, ToJSONKey, FromJSONKey) instance Pretty CoverageAnnotation where @@ -106,7 +102,7 @@ data Metadata = ApplicationHeadSymbol String -- compiler, but can be added later using `addCoverageMetadata`. deriving stock (Ord, Eq, Show, Generic) deriving anyclass (Serialise) - deriving Flat via (AsSerialize Metadata) + deriving Flat via (FlatViaSerialise Metadata) deriving anyclass (NFData, ToJSON, FromJSON) instance Pretty Metadata where @@ -116,7 +112,7 @@ newtype CoverageMetadata = CoverageMetadata { _metadataSet :: Set Metadata } deriving stock (Ord, Eq, Show, Generic) deriving anyclass (Serialise, NFData, ToJSON, FromJSON) deriving newtype (Semigroup, Monoid) - deriving Flat via (AsSerialize CoverageMetadata) + deriving Flat via (FlatViaSerialise CoverageMetadata) makeLenses ''CoverageMetadata @@ -125,11 +121,12 @@ instance Pretty CoverageMetadata where -- | This type keeps track of all coverage annotations and where they have been inserted / what -- annotations are expected to be found when executing a piece of code. -data CoverageIndex = CoverageIndex { _coverageMetadata :: Map CoverageAnnotation CoverageMetadata } - deriving stock (Ord, Eq, Show, Generic) - deriving anyclass (Serialise) - deriving Flat via (AsSerialize CoverageIndex) - deriving anyclass (NFData, ToJSON, FromJSON) +newtype CoverageIndex = CoverageIndex + { _coverageMetadata :: Map CoverageAnnotation CoverageMetadata } + deriving stock (Ord, Eq, Show, Generic) + deriving anyclass (Serialise) + deriving Flat via (FlatViaSerialise CoverageIndex) + deriving anyclass (NFData, ToJSON, FromJSON) makeLenses ''CoverageIndex @@ -154,19 +151,21 @@ addLocationToCoverageIndex src = do pure ann -- | Include a boolean coverage annotation in the index -addBoolCaseToCoverageIndex :: MonadWriter CoverageIndex m => CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation +addBoolCaseToCoverageIndex :: MonadWriter CoverageIndex m + => CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation addBoolCaseToCoverageIndex src b meta = do - let ann = boolCaseCoverageAnn src b + let ann = CoverBool src b tell $ CoverageIndex (Map.singleton ann meta) pure ann -- | Add metadata to a coverage annotation. Does nothing if the annotation is not in the index. addCoverageMetadata :: CoverageAnnotation -> Metadata -> CoverageIndex -> CoverageIndex -addCoverageMetadata ann meta idx = idx & coverageMetadata . at ann . _Just . metadataSet %~ Set.insert meta - -{-# INLINE boolCaseCoverageAnn #-} -boolCaseCoverageAnn :: CovLoc -> Bool -> CoverageAnnotation -boolCaseCoverageAnn src b = CoverBool src b +addCoverageMetadata ann meta idx = idx + & coverageMetadata + . at ann + . _Just + . metadataSet + %~ Set.insert meta newtype CoverageData = CoverageData { _coveredAnnotations :: Set CoverageAnnotation } deriving stock (Ord, Eq, Show, Generic) @@ -193,14 +192,14 @@ coverageDataFromLogMsg :: String -> CoverageData coverageDataFromLogMsg = foldMap (CoverageData . Set.singleton) . readMaybe instance Pretty CoverageReport where - pretty report = - vsep $ ["=========[COVERED]=========="] ++ - [ nest 4 $ vsep (pretty ann : (map pretty . Set.toList . foldMap _metadataSet $ metadata ann)) - | ann <- Set.toList $ allAnns `Set.intersection` coveredAnns ] ++ - ["========[UNCOVERED]========="] ++ - (map pretty . Set.toList $ uncoveredAnns) ++ - ["=========[IGNORED]=========="] ++ - (map pretty . Set.toList $ ignoredAnns Set.\\ coveredAnns) + pretty report = vsep $ + ["=========[COVERED]=========="] ++ + [ nest 4 $ vsep (pretty ann : (map pretty . Set.toList . foldMap _metadataSet $ metadata ann)) + | ann <- Set.toList $ allAnns `Set.intersection` coveredAnns ] ++ + ["========[UNCOVERED]========="] ++ + (map pretty . Set.toList $ uncoveredAnns) ++ + ["=========[IGNORED]=========="] ++ + (map pretty . Set.toList $ ignoredAnns Set.\\ coveredAnns) where allAnns = report ^. coverageIndex . coverageAnnotations coveredAnns = report ^. coverageData . coveredAnnotations