{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Plutus.Contract.Test.Coverage.Analysis
  ( computeRefinedCoverageIndex
  , refinedCoverageIndex
  ) where

import Control.Lens

import Data.Map qualified as Map
import Data.Set qualified as Set

import PlutusCore.Default
import PlutusTx.Code
import PlutusTx.Coverage

import Plutus.Contract.Test.Coverage.Analysis.Interpreter

import Language.Haskell.TH

unsafeIgnoreLocationInCoverageIndex :: String -> Int -> CoverageIndex -> CoverageIndex
unsafeIgnoreLocationInCoverageIndex :: String -> Int -> CoverageIndex -> CoverageIndex
unsafeIgnoreLocationInCoverageIndex String
file Int
line =
  ASetter
  CoverageIndex
  CoverageIndex
  (Map CoverageAnnotation CoverageMetadata)
  (Map CoverageAnnotation CoverageMetadata)
-> (Map CoverageAnnotation CoverageMetadata
    -> Map CoverageAnnotation CoverageMetadata)
-> CoverageIndex
-> CoverageIndex
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  CoverageIndex
  CoverageIndex
  (Map CoverageAnnotation CoverageMetadata)
  (Map CoverageAnnotation CoverageMetadata)
Iso' CoverageIndex (Map CoverageAnnotation CoverageMetadata)
coverageMetadata ((Map CoverageAnnotation CoverageMetadata
  -> Map CoverageAnnotation CoverageMetadata)
 -> CoverageIndex -> CoverageIndex)
-> (Map CoverageAnnotation CoverageMetadata
    -> Map CoverageAnnotation CoverageMetadata)
-> CoverageIndex
-> CoverageIndex
forall a b. (a -> b) -> a -> b
$ (CoverageAnnotation -> CoverageMetadata -> Bool)
-> Map CoverageAnnotation CoverageMetadata
-> Map CoverageAnnotation CoverageMetadata
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\CoverageAnnotation
k CoverageMetadata
_ -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation -> Bool
ignore CoverageAnnotation
k)
  where
    ignore :: CoverageAnnotation -> Bool
ignore (CoverLocation CovLoc
loc') = CovLoc -> Bool
ignoreLoc CovLoc
loc'
    ignore (CoverBool CovLoc
loc' Bool
_)   = CovLoc -> Bool
ignoreLoc CovLoc
loc'
    ignoreLoc :: CovLoc -> Bool
ignoreLoc CovLoc
loc = Getting String CovLoc String -> CovLoc -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String CovLoc String
Lens' CovLoc String
covLocFile CovLoc
loc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
file
                 Bool -> Bool -> Bool
&& Getting Int CovLoc Int -> CovLoc -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int CovLoc Int
Lens' CovLoc Int
covLocStartLine CovLoc
loc Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
line) [-Int
1, Int
0, Int
1]

refinedCoverageIndex :: Q Exp
refinedCoverageIndex :: Q Exp
refinedCoverageIndex = do
  Loc
loc <- Q Loc
location
  let fn :: String
fn = Loc -> String
loc_filename Loc
loc
      st :: Int
st = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
loc_start Loc
loc
  [| unsafeIgnoreLocationInCoverageIndex fn st . computeRefinedCoverageIndex |]

computeRefinedCoverageIndex :: CompiledCodeIn DefaultUni DefaultFun a -> CoverageIndex
computeRefinedCoverageIndex :: CompiledCodeIn DefaultUni DefaultFun a -> CoverageIndex
computeRefinedCoverageIndex CompiledCodeIn DefaultUni DefaultFun a
cc =
    (CoverageAnnotation -> CoverageIndex -> CoverageIndex)
-> CoverageIndex -> [CoverageAnnotation] -> CoverageIndex
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((CoverageAnnotation -> Metadata -> CoverageIndex -> CoverageIndex)
-> Metadata -> CoverageAnnotation -> CoverageIndex -> CoverageIndex
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoverageAnnotation -> Metadata -> CoverageIndex -> CoverageIndex
addCoverageMetadata Metadata
IgnoredAnnotation) CoverageIndex
covIdx (Set CoverageAnnotation -> [CoverageAnnotation]
forall a. Set a -> [a]
Set.toList Set CoverageAnnotation
ignoredLocs)
  where
    covIdx :: CoverageIndex
covIdx        = CompiledCodeIn DefaultUni DefaultFun a -> CoverageIndex
forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx CompiledCodeIn DefaultUni DefaultFun a
cc
    importantLocs :: Set CoverageAnnotation
importantLocs = CompiledCodeIn DefaultUni DefaultFun a -> Set CoverageAnnotation
forall a.
HasCallStack =>
CompiledCodeIn DefaultUni DefaultFun a -> Set CoverageAnnotation
allNonFailLocations CompiledCodeIn DefaultUni DefaultFun a
cc
    ignoredLocs :: Set CoverageAnnotation
ignoredLocs   = CoverageIndex
covIdx CoverageIndex
-> Getting
     (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
-> Set CoverageAnnotation
forall s a. s -> Getting a s a -> a
^. (Map CoverageAnnotation CoverageMetadata
 -> Const
      (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata))
-> CoverageIndex -> Const (Set CoverageAnnotation) CoverageIndex
Iso' CoverageIndex (Map CoverageAnnotation CoverageMetadata)
coverageMetadata ((Map CoverageAnnotation CoverageMetadata
  -> Const
       (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata))
 -> CoverageIndex -> Const (Set CoverageAnnotation) CoverageIndex)
-> ((Set CoverageAnnotation
     -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
    -> Map CoverageAnnotation CoverageMetadata
    -> Const
         (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata))
-> Getting
     (Set CoverageAnnotation) CoverageIndex (Set CoverageAnnotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation)
-> (Set CoverageAnnotation
    -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
-> Map CoverageAnnotation CoverageMetadata
-> Const
     (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Map CoverageAnnotation CoverageMetadata -> Set CoverageAnnotation
forall k a. Map k a -> Set k
Map.keysSet ((Set CoverageAnnotation
  -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
 -> Map CoverageAnnotation CoverageMetadata
 -> Const
      (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata))
-> ((Set CoverageAnnotation
     -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
    -> Set CoverageAnnotation
    -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
-> (Set CoverageAnnotation
    -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
-> Map CoverageAnnotation CoverageMetadata
-> Const
     (Set CoverageAnnotation) (Map CoverageAnnotation CoverageMetadata)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set CoverageAnnotation -> Set CoverageAnnotation)
-> (Set CoverageAnnotation
    -> Const (Set CoverageAnnotation) (Set CoverageAnnotation))
-> Set CoverageAnnotation
-> Const (Set CoverageAnnotation) (Set CoverageAnnotation)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Set CoverageAnnotation
-> Set CoverageAnnotation -> Set CoverageAnnotation
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set CoverageAnnotation
importantLocs)