Merge pull request #4552 from Quviq/PR-coverage-report (#4655)

Minor coverage report changes
IntersectMBO · May 26, 2022 · 36afae9 · 36afae9
1 parent 0a8b1ad
commit 36afae9
Showing 1 changed file with 58 additions and 14 deletions.
diff --git a/plutus-tx/src/PlutusTx/Coverage.hs b/plutus-tx/src/PlutusTx/Coverage.hs
@@ -10,6 +10,7 @@ module PlutusTx.Coverage ( CoverageAnnotation(..)
                          , CoverageIndex(..)
                          , CoverageMetadata(..)
                          , Metadata(..)
+                         , CoverageData(..)
                          , CoverageReport(..)
                          , CovLoc(..)
                          , covLocFile
@@ -19,12 +20,13 @@ module PlutusTx.Coverage ( CoverageAnnotation(..)
                          , covLocEndCol
                          , metadataSet
                          , coverageAnnotations
+                         , ignoredAnnotations
                          , coverageMetadata
                          , coveredAnnotations
+                         , addCoverageMetadata
                          , addLocationToCoverageIndex
                          , addBoolCaseToCoverageIndex
-                         , coverageReportFromLogMsg
-                         , pprCoverageReport
+                         , coverageDataFromLogMsg
                          ) where
 
 import Control.Lens
@@ -33,6 +35,8 @@ import Codec.Serialise
 
 import PlutusCore.Flat
 
+import Control.DeepSeq
+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
 import Data.Foldable
 import Data.Map (Map)
 import Data.Map qualified as Map
@@ -76,6 +80,7 @@ data CovLoc = CovLoc { _covLocFile      :: String
   deriving stock (Ord, Eq, Show, Read, Generic)
   deriving anyclass (Serialise)
   deriving Flat via (AsSerialize CovLoc)
+  deriving anyclass (NFData, ToJSON, FromJSON)
 
 makeLenses ''CovLoc
 
@@ -88,22 +93,27 @@ data CoverageAnnotation = CoverLocation CovLoc
                         deriving stock (Ord, Eq, Show, Read, Generic)
                         deriving anyclass (Serialise)
                         deriving Flat via (AsSerialize CoverageAnnotation)
+                        deriving anyclass (NFData, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
 
 instance Pretty CoverageAnnotation where
   pretty (CoverLocation loc) = pretty loc
   pretty (CoverBool loc b)   = pretty loc <+> "=" <+> pretty b
 
 data Metadata = ApplicationHeadSymbol String
+              | IgnoredAnnotation
+                -- ^ Location that is not interesting to cover. This is not generated by the
+                --   compiler, but can be added later using `addCoverageMetadata`.
     deriving stock (Ord, Eq, Show, Generic)
     deriving anyclass (Serialise)
     deriving Flat via (AsSerialize Metadata)
+    deriving anyclass (NFData, ToJSON, FromJSON)
 
 instance Pretty Metadata where
   pretty = viaShow
 
 newtype CoverageMetadata = CoverageMetadata { _metadataSet :: Set Metadata }
     deriving stock (Ord, Eq, Show, Generic)
-    deriving anyclass (Serialise)
+    deriving anyclass (Serialise, NFData, ToJSON, FromJSON)
     deriving newtype (Semigroup, Monoid)
     deriving Flat via (AsSerialize CoverageMetadata)
 
@@ -118,12 +128,17 @@ data CoverageIndex = CoverageIndex { _coverageMetadata :: Map CoverageAnnotation
                       deriving stock (Ord, Eq, Show, Generic)
                       deriving anyclass (Serialise)
                       deriving Flat via (AsSerialize CoverageIndex)
+                      deriving anyclass (NFData, ToJSON, FromJSON)
 
 makeLenses ''CoverageIndex
 
 coverageAnnotations :: Getter CoverageIndex (Set CoverageAnnotation)
 coverageAnnotations = coverageMetadata . to Map.keysSet
 
+ignoredAnnotations :: Getter CoverageIndex (Set CoverageAnnotation)
+ignoredAnnotations = coverageMetadata
+                   . to (Map.keysSet . Map.filter (Set.member IgnoredAnnotation . _metadataSet))
+
 instance Semigroup CoverageIndex where
   ci <> ci' = CoverageIndex (Map.unionWith (<>) (_coverageMetadata ci) (_coverageMetadata ci'))
 
@@ -144,23 +159,52 @@ addBoolCaseToCoverageIndex src b meta = do
   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
 
-newtype CoverageReport = CoverageReport { _coveredAnnotations :: Set CoverageAnnotation }
-  deriving stock (Ord, Eq, Show)
+newtype CoverageData = CoverageData { _coveredAnnotations :: Set CoverageAnnotation }
+  deriving stock (Ord, Eq, Show, Generic)
   deriving newtype (Semigroup, Monoid)
+  deriving anyclass (NFData, ToJSON, FromJSON)
+
+makeLenses ''CoverageData
+
+data CoverageReport = CoverageReport { _coverageIndex :: CoverageIndex
+                                     , _coverageData  :: CoverageData }
+  deriving stock (Ord, Eq, Show, Generic)
+  deriving anyclass (NFData, ToJSON, FromJSON)
 
 makeLenses ''CoverageReport
 
-coverageReportFromLogMsg :: String -> CoverageReport
-coverageReportFromLogMsg = foldMap (CoverageReport . Set.singleton) . readMaybe
+instance Semigroup CoverageReport where
+  CoverageReport i1 d1 <> CoverageReport i2 d2 = CoverageReport (i1 <> i2) (d1 <> d2)
+
+instance Monoid CoverageReport where
+  mempty  = CoverageReport mempty mempty
+  mappend = (<>)
+
+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)
+    where
+      allAnns       = report ^. coverageIndex . coverageAnnotations
+      coveredAnns   = report ^. coverageData  . coveredAnnotations
+      ignoredAnns   = report ^. coverageIndex . ignoredAnnotations
+      uncoveredAnns = allAnns Set.\\ (coveredAnns <> ignoredAnns)
+
+      metadata ann = Map.lookup ann (report ^. coverageIndex . coverageMetadata)
 
-pprCoverageReport :: CoverageIndex -> CoverageReport -> Doc ann
-pprCoverageReport covIdx report =
-  vsep $ ["=========[COVERED]=========="] ++
-         [ nest 4 $ vsep (pretty ann : (map pretty . Set.toList . foldMap _metadataSet $ Map.lookup ann (_coverageMetadata covIdx)))
-         | ann <- Set.toList $ (covIdx ^. coverageAnnotations) `Set.intersection` (report ^. coveredAnnotations) ] ++
-         ["========[UNCOVERED]========="] ++
-         (map pretty . Set.toList $ (covIdx ^. coverageAnnotations) Set.\\ (report ^. coveredAnnotations))