{-# LANGUAGE DerivingStrategies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Plutus.Contract.Test.Coverage
  ( getInvokedEndpoints
  , getCoverageData
  , CoverageRef(..)
  , newCoverageRef
  , readCoverageRef
  , writeCoverageReport
  ) where

import Control.Lens
import Data.Foldable
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text

import Cardano.Node.Emulator.Internal.Node
import Ledger.Index (getEvaluationLogs)
import Plutus.Trace.Emulator.Types
import PlutusTx.Coverage
import Wallet.Emulator.MultiAgent (EmulatorEvent, EmulatorEvent' (..), EmulatorTimeEvent (..), eteEvent)
import Wallet.Types

import Data.IORef
import Plutus.Contract.Test.Coverage.ReportCoverage qualified as ReportCoverage


-- | Get every endpoint name that has been invoked in the emulator events in `es`
-- indexed by `ContractInstanceTag`
getInvokedEndpoints :: [EmulatorEvent] -> Map ContractInstanceTag (Set String)
getInvokedEndpoints :: [EmulatorEvent] -> Map ContractInstanceTag (Set String)
getInvokedEndpoints [EmulatorEvent]
es =
  let cs :: [(ContractInstanceTag, ContractInstanceMsg)]
cs = [ (Getting ContractInstanceTag ContractInstanceLog ContractInstanceTag
-> ContractInstanceLog -> ContractInstanceTag
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ContractInstanceTag ContractInstanceLog ContractInstanceTag
Lens' ContractInstanceLog ContractInstanceTag
cilTag ContractInstanceLog
c, Getting ContractInstanceMsg ContractInstanceLog ContractInstanceMsg
-> ContractInstanceLog -> ContractInstanceMsg
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ContractInstanceMsg ContractInstanceLog ContractInstanceMsg
Lens' ContractInstanceLog ContractInstanceMsg
cilMessage ContractInstanceLog
c) | EmulatorTimeEvent Slot
_ (InstanceEvent ContractInstanceLog
c) <- [EmulatorEvent]
es ]
      t2ep :: [(ContractInstanceTag, String)]
t2ep = [ (ContractInstanceTag
t, String
ep) | (ContractInstanceTag
t, ReceiveEndpointCall (EndpointDescription String
ep) Value
_) <- [(ContractInstanceTag, ContractInstanceMsg)]
cs ]
      epsCovered :: Map ContractInstanceTag (Set String)
epsCovered = ((ContractInstanceTag, String)
 -> Map ContractInstanceTag (Set String)
 -> Map ContractInstanceTag (Set String))
-> Map ContractInstanceTag (Set String)
-> [(ContractInstanceTag, String)]
-> Map ContractInstanceTag (Set String)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(ContractInstanceTag
t, String
ep) -> (Set String -> Set String -> Set String)
-> ContractInstanceTag
-> Set String
-> Map ContractInstanceTag (Set String)
-> Map ContractInstanceTag (Set String)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union ContractInstanceTag
t (String -> Set String
forall a. a -> Set a
Set.singleton String
ep)) Map ContractInstanceTag (Set String)
forall k a. Map k a
Map.empty [(ContractInstanceTag, String)]
t2ep
  in Map ContractInstanceTag (Set String)
epsCovered

-- | Collect every executed coverage annotation in the validators executed in `es`
getCoverageData :: [EmulatorEvent] -> CoverageData
getCoverageData :: [EmulatorEvent] -> CoverageData
getCoverageData [EmulatorEvent]
es =
  let extractLog :: EmulatorEvent' -> [Text]
extractLog EmulatorEvent'
e = case EmulatorEvent'
e of
        ChainEvent (TxnValidation ValidationResult
res) -> ValidationResult -> [Text]
getEvaluationLogs ValidationResult
res
        EmulatorEvent'
_                              -> []

  in [CoverageData] -> CoverageData
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([CoverageData] -> CoverageData) -> [CoverageData] -> CoverageData
forall a b. (a -> b) -> a -> b
$ do
    EmulatorEvent
event <- [EmulatorEvent]
es
    Text
logEvent <- EmulatorEvent' -> [Text]
extractLog (EmulatorEvent' -> [Text]) -> EmulatorEvent' -> [Text]
forall a b. (a -> b) -> a -> b
$ EmulatorEvent
event EmulatorEvent
-> Getting EmulatorEvent' EmulatorEvent EmulatorEvent'
-> EmulatorEvent'
forall s a. s -> Getting a s a -> a
^. Getting EmulatorEvent' EmulatorEvent EmulatorEvent'
forall e1 e2.
Lens (EmulatorTimeEvent e1) (EmulatorTimeEvent e2) e1 e2
eteEvent
    let msg :: String
msg = Text -> String
Text.unpack Text
logEvent
    CoverageData -> [CoverageData]
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverageData -> [CoverageData]) -> CoverageData -> [CoverageData]
forall a b. (a -> b) -> a -> b
$ String -> CoverageData
coverageDataFromLogMsg String
msg

newtype CoverageRef = CoverageRef (IORef CoverageData)

newCoverageRef :: IO CoverageRef
newCoverageRef :: IO CoverageRef
newCoverageRef = IORef CoverageData -> CoverageRef
CoverageRef (IORef CoverageData -> CoverageRef)
-> IO (IORef CoverageData) -> IO CoverageRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoverageData -> IO (IORef CoverageData)
forall a. a -> IO (IORef a)
newIORef CoverageData
forall a. Monoid a => a
mempty

readCoverageRef :: CoverageRef -> IO CoverageData
readCoverageRef :: CoverageRef -> IO CoverageData
readCoverageRef (CoverageRef IORef CoverageData
ioref) = IORef CoverageData -> IO CoverageData
forall a. IORef a -> IO a
readIORef IORef CoverageData
ioref

-- | Write a coverage report to name.html for the given index.
writeCoverageReport :: String -> CoverageReport -> IO ()
writeCoverageReport :: String -> CoverageReport -> IO ()
writeCoverageReport = String -> CoverageReport -> IO ()
ReportCoverage.writeCoverageReport