{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -fno-warn-orphans  #-}

module Plutus.Contract.Test.Certification.Run
  ( -- * A certification report holds all the necessary information
    -- to make sense of certification results
    CertificationReport
  , certResJSON
  -- * There are a tonne of lenses
  , certRes_standardPropertyResult
  -- TODO: turn on when double satisfaction is activated again
  -- , certRes_doubleSatisfactionResult
  , certRes_noLockedFundsResult
  , certRes_noLockedFundsLightResult
  , certRes_standardCrashToleranceResult
  , certRes_unitTestResults
  , certRes_coverageReport
  , certRes_whitelistOk
  , certRes_whitelistResult
  , certRes_DLTests
  -- * and we have a function for running certification
  , CertificationOptions(..)
  , CertificationEvent(..)
  , CertificationTask(..)
  , certificationTasks
  , hasQuickCheckTests
  , defaultCertificationOptions
  , certify
  , certifyWithOptions
  ) where

import Control.Concurrent.Chan
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad.Writer
import Data.Aeson (FromJSON (..), ToJSON (..), encode)
import Data.ByteString.Lazy.Char8 (unpack)
import Data.IntMap qualified as IntMap
import Data.Maybe
import GHC.Generics
import Plutus.Contract.Test.Certification
import Plutus.Contract.Test.ContractModel
import Plutus.Contract.Test.ContractModel.CrashTolerance
import PlutusTx.Coverage
import System.Random.SplitMix
import Test.QuickCheck as QC
import Test.QuickCheck.Property
import Test.QuickCheck.Random as QC
import Test.Tasty qualified as Tasty
import Test.Tasty.Runners qualified as Tasty
import Text.Read hiding (lift)

newtype JSONShowRead a = JSONShowRead a

instance Show a => ToJSON (JSONShowRead a) where
  toJSON :: JSONShowRead a -> Value
toJSON (JSONShowRead a
a) = String -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> String
forall a. Show a => a -> String
show a
a)

instance Read a => FromJSON (JSONShowRead a) where
  parseJSON :: Value -> Parser (JSONShowRead a)
parseJSON Value
v = do
    String
str <- Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str of
      Maybe a
Nothing -> String -> Parser (JSONShowRead a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JSONShowRead: readMaybe Nothing"
      Just a
a  -> JSONShowRead a -> Parser (JSONShowRead a)
forall (m :: * -> *) a. Monad m => a -> m a
return (JSONShowRead a -> Parser (JSONShowRead a))
-> JSONShowRead a -> Parser (JSONShowRead a)
forall a b. (a -> b) -> a -> b
$ a -> JSONShowRead a
forall a. a -> JSONShowRead a
JSONShowRead a
a

deriving via (JSONShowRead SMGen) instance FromJSON SMGen
deriving via (JSONShowRead SMGen) instance ToJSON SMGen

deriving via SMGen instance FromJSON QCGen
deriving via SMGen instance ToJSON QCGen
deriving instance Generic QC.Result
deriving instance ToJSON QC.Result
deriving instance FromJSON QC.Result

instance ToJSON SomeException where
  toJSON :: SomeException -> Value
toJSON (SomeException e
e) = String -> Value
forall a. ToJSON a => a -> Value
toJSON (e -> String
forall a. Show a => a -> String
show e
e)
instance FromJSON SomeException where
  parseJSON :: Value -> Parser SomeException
parseJSON Value
v = do
    String
str <- Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    SomeException -> Parser SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Parser SomeException)
-> SomeException -> Parser SomeException
forall a b. (a -> b) -> a -> b
$ ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
SomeException (String -> ErrorCall
ErrorCall String
str)

data TastyResult = Result
  { TastyResult -> Outcome
resultOutcome          :: Tasty.Outcome
  , TastyResult -> String
resultDescription      :: String
  , TastyResult -> String
resultShortDescription :: String
  , TastyResult -> Time
resultTime             :: Tasty.Time
  }
  deriving ((forall x. TastyResult -> Rep TastyResult x)
-> (forall x. Rep TastyResult x -> TastyResult)
-> Generic TastyResult
forall x. Rep TastyResult x -> TastyResult
forall x. TastyResult -> Rep TastyResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TastyResult x -> TastyResult
$cfrom :: forall x. TastyResult -> Rep TastyResult x
Generic, [TastyResult] -> Value
[TastyResult] -> Encoding
TastyResult -> Value
TastyResult -> Encoding
(TastyResult -> Value)
-> (TastyResult -> Encoding)
-> ([TastyResult] -> Value)
-> ([TastyResult] -> Encoding)
-> ToJSON TastyResult
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TastyResult] -> Encoding
$ctoEncodingList :: [TastyResult] -> Encoding
toJSONList :: [TastyResult] -> Value
$ctoJSONList :: [TastyResult] -> Value
toEncoding :: TastyResult -> Encoding
$ctoEncoding :: TastyResult -> Encoding
toJSON :: TastyResult -> Value
$ctoJSON :: TastyResult -> Value
ToJSON)

deriving instance Generic Tasty.FailureReason
deriving instance ToJSON Tasty.FailureReason
deriving instance ToJSON Tasty.Outcome

instance ToJSON Tasty.Result where
  toJSON :: Result -> Value
toJSON Result
r = TastyResult -> Value
forall a. ToJSON a => a -> Value
toJSON (TastyResult -> Value) -> TastyResult -> Value
forall a b. (a -> b) -> a -> b
$ Result :: Outcome -> String -> String -> Time -> TastyResult
Result { resultOutcome :: Outcome
resultOutcome          = Result -> Outcome
Tasty.resultOutcome Result
r
                             , resultDescription :: String
resultDescription      = Result -> String
Tasty.resultDescription Result
r
                             , resultShortDescription :: String
resultShortDescription = Result -> String
Tasty.resultShortDescription Result
r
                             , resultTime :: Time
resultTime             = Result -> Time
Tasty.resultTime Result
r
                             }

data CertificationReport m = CertificationReport {
    CertificationReport m -> Result
_certRes_standardPropertyResult       :: QC.Result,
    -- TODO: turn on again later
    -- _certRes_doubleSatisfactionResult     :: QC.Result,
    CertificationReport m -> Maybe Result
_certRes_noLockedFundsResult          :: Maybe QC.Result,
    CertificationReport m -> Maybe Result
_certRes_noLockedFundsLightResult     :: Maybe QC.Result,
    CertificationReport m -> Maybe Result
_certRes_standardCrashToleranceResult :: Maybe QC.Result,
    CertificationReport m -> [Result]
_certRes_unitTestResults              :: [Tasty.Result],
    CertificationReport m -> CoverageReport
_certRes_coverageReport               :: CoverageReport,
    CertificationReport m -> Maybe Bool
_certRes_whitelistOk                  :: Maybe Bool,
    CertificationReport m -> Maybe Result
_certRes_whitelistResult              :: Maybe QC.Result,
    CertificationReport m -> [(String, Result)]
_certRes_DLTests                      :: [(String, QC.Result)]
  } deriving (Int -> CertificationReport m -> ShowS
[CertificationReport m] -> ShowS
CertificationReport m -> String
(Int -> CertificationReport m -> ShowS)
-> (CertificationReport m -> String)
-> ([CertificationReport m] -> ShowS)
-> Show (CertificationReport m)
forall m. Int -> CertificationReport m -> ShowS
forall m. [CertificationReport m] -> ShowS
forall m. CertificationReport m -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertificationReport m] -> ShowS
$cshowList :: forall m. [CertificationReport m] -> ShowS
show :: CertificationReport m -> String
$cshow :: forall m. CertificationReport m -> String
showsPrec :: Int -> CertificationReport m -> ShowS
$cshowsPrec :: forall m. Int -> CertificationReport m -> ShowS
Show, (forall x. CertificationReport m -> Rep (CertificationReport m) x)
-> (forall x.
    Rep (CertificationReport m) x -> CertificationReport m)
-> Generic (CertificationReport m)
forall x. Rep (CertificationReport m) x -> CertificationReport m
forall x. CertificationReport m -> Rep (CertificationReport m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall m x. Rep (CertificationReport m) x -> CertificationReport m
forall m x. CertificationReport m -> Rep (CertificationReport m) x
$cto :: forall m x. Rep (CertificationReport m) x -> CertificationReport m
$cfrom :: forall m x. CertificationReport m -> Rep (CertificationReport m) x
Generic, [CertificationReport m] -> Value
[CertificationReport m] -> Encoding
CertificationReport m -> Value
CertificationReport m -> Encoding
(CertificationReport m -> Value)
-> (CertificationReport m -> Encoding)
-> ([CertificationReport m] -> Value)
-> ([CertificationReport m] -> Encoding)
-> ToJSON (CertificationReport m)
forall m. [CertificationReport m] -> Value
forall m. [CertificationReport m] -> Encoding
forall m. CertificationReport m -> Value
forall m. CertificationReport m -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CertificationReport m] -> Encoding
$ctoEncodingList :: forall m. [CertificationReport m] -> Encoding
toJSONList :: [CertificationReport m] -> Value
$ctoJSONList :: forall m. [CertificationReport m] -> Value
toEncoding :: CertificationReport m -> Encoding
$ctoEncoding :: forall m. CertificationReport m -> Encoding
toJSON :: CertificationReport m -> Value
$ctoJSON :: forall m. CertificationReport m -> Value
ToJSON)
makeLenses ''CertificationReport

certResJSON :: CertificationReport m -> String
certResJSON :: CertificationReport m -> String
certResJSON = ByteString -> String
unpack (ByteString -> String)
-> (CertificationReport m -> ByteString)
-> CertificationReport m
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificationReport m -> ByteString
forall a. ToJSON a => a -> ByteString
encode

data CertificationEvent = QuickCheckTestEvent (Maybe Bool)  -- ^ Nothing if discarded, otherwise test result
                        | QuickCheckNumTestsEvent Int
                        | StartCertificationTask CertificationTask
                        | FinishedTask Bool
                        | CertificationDone
  deriving (CertificationEvent -> CertificationEvent -> Bool
(CertificationEvent -> CertificationEvent -> Bool)
-> (CertificationEvent -> CertificationEvent -> Bool)
-> Eq CertificationEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertificationEvent -> CertificationEvent -> Bool
$c/= :: CertificationEvent -> CertificationEvent -> Bool
== :: CertificationEvent -> CertificationEvent -> Bool
$c== :: CertificationEvent -> CertificationEvent -> Bool
Eq, Int -> CertificationEvent -> ShowS
[CertificationEvent] -> ShowS
CertificationEvent -> String
(Int -> CertificationEvent -> ShowS)
-> (CertificationEvent -> String)
-> ([CertificationEvent] -> ShowS)
-> Show CertificationEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertificationEvent] -> ShowS
$cshowList :: [CertificationEvent] -> ShowS
show :: CertificationEvent -> String
$cshow :: CertificationEvent -> String
showsPrec :: Int -> CertificationEvent -> ShowS
$cshowsPrec :: Int -> CertificationEvent -> ShowS
Show)

data CertificationTask = UnitTestsTask
                       | StandardPropertyTask
                       -- | DoubleSatisfactionTask
                       | NoLockedFundsTask
                       | NoLockedFundsLightTask
                       | CrashToleranceTask
                       | WhitelistTask
                       | DLTestsTask
  deriving (CertificationTask -> CertificationTask -> Bool
(CertificationTask -> CertificationTask -> Bool)
-> (CertificationTask -> CertificationTask -> Bool)
-> Eq CertificationTask
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CertificationTask -> CertificationTask -> Bool
$c/= :: CertificationTask -> CertificationTask -> Bool
== :: CertificationTask -> CertificationTask -> Bool
$c== :: CertificationTask -> CertificationTask -> Bool
Eq, Int -> CertificationTask -> ShowS
[CertificationTask] -> ShowS
CertificationTask -> String
(Int -> CertificationTask -> ShowS)
-> (CertificationTask -> String)
-> ([CertificationTask] -> ShowS)
-> Show CertificationTask
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CertificationTask] -> ShowS
$cshowList :: [CertificationTask] -> ShowS
show :: CertificationTask -> String
$cshow :: CertificationTask -> String
showsPrec :: Int -> CertificationTask -> ShowS
$cshowsPrec :: Int -> CertificationTask -> ShowS
Show, Int -> CertificationTask
CertificationTask -> Int
CertificationTask -> [CertificationTask]
CertificationTask -> CertificationTask
CertificationTask -> CertificationTask -> [CertificationTask]
CertificationTask
-> CertificationTask -> CertificationTask -> [CertificationTask]
(CertificationTask -> CertificationTask)
-> (CertificationTask -> CertificationTask)
-> (Int -> CertificationTask)
-> (CertificationTask -> Int)
-> (CertificationTask -> [CertificationTask])
-> (CertificationTask -> CertificationTask -> [CertificationTask])
-> (CertificationTask -> CertificationTask -> [CertificationTask])
-> (CertificationTask
    -> CertificationTask -> CertificationTask -> [CertificationTask])
-> Enum CertificationTask
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CertificationTask
-> CertificationTask -> CertificationTask -> [CertificationTask]
$cenumFromThenTo :: CertificationTask
-> CertificationTask -> CertificationTask -> [CertificationTask]
enumFromTo :: CertificationTask -> CertificationTask -> [CertificationTask]
$cenumFromTo :: CertificationTask -> CertificationTask -> [CertificationTask]
enumFromThen :: CertificationTask -> CertificationTask -> [CertificationTask]
$cenumFromThen :: CertificationTask -> CertificationTask -> [CertificationTask]
enumFrom :: CertificationTask -> [CertificationTask]
$cenumFrom :: CertificationTask -> [CertificationTask]
fromEnum :: CertificationTask -> Int
$cfromEnum :: CertificationTask -> Int
toEnum :: Int -> CertificationTask
$ctoEnum :: Int -> CertificationTask
pred :: CertificationTask -> CertificationTask
$cpred :: CertificationTask -> CertificationTask
succ :: CertificationTask -> CertificationTask
$csucc :: CertificationTask -> CertificationTask
Enum, CertificationTask
CertificationTask -> CertificationTask -> Bounded CertificationTask
forall a. a -> a -> Bounded a
maxBound :: CertificationTask
$cmaxBound :: CertificationTask
minBound :: CertificationTask
$cminBound :: CertificationTask
Bounded, Eq CertificationTask
Eq CertificationTask
-> (CertificationTask -> CertificationTask -> Ordering)
-> (CertificationTask -> CertificationTask -> Bool)
-> (CertificationTask -> CertificationTask -> Bool)
-> (CertificationTask -> CertificationTask -> Bool)
-> (CertificationTask -> CertificationTask -> Bool)
-> (CertificationTask -> CertificationTask -> CertificationTask)
-> (CertificationTask -> CertificationTask -> CertificationTask)
-> Ord CertificationTask
CertificationTask -> CertificationTask -> Bool
CertificationTask -> CertificationTask -> Ordering
CertificationTask -> CertificationTask -> CertificationTask
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CertificationTask -> CertificationTask -> CertificationTask
$cmin :: CertificationTask -> CertificationTask -> CertificationTask
max :: CertificationTask -> CertificationTask -> CertificationTask
$cmax :: CertificationTask -> CertificationTask -> CertificationTask
>= :: CertificationTask -> CertificationTask -> Bool
$c>= :: CertificationTask -> CertificationTask -> Bool
> :: CertificationTask -> CertificationTask -> Bool
$c> :: CertificationTask -> CertificationTask -> Bool
<= :: CertificationTask -> CertificationTask -> Bool
$c<= :: CertificationTask -> CertificationTask -> Bool
< :: CertificationTask -> CertificationTask -> Bool
$c< :: CertificationTask -> CertificationTask -> Bool
compare :: CertificationTask -> CertificationTask -> Ordering
$ccompare :: CertificationTask -> CertificationTask -> Ordering
$cp1Ord :: Eq CertificationTask
Ord)

hasQuickCheckTests :: CertificationTask -> Bool
hasQuickCheckTests :: CertificationTask -> Bool
hasQuickCheckTests CertificationTask
t = CertificationTask
t CertificationTask -> CertificationTask -> Bool
forall a. Eq a => a -> a -> Bool
/= CertificationTask
UnitTestsTask

-- | The list of certification tasks that will be run for a given certification object.
certificationTasks :: Certification m -> [CertificationTask]
certificationTasks :: Certification m -> [CertificationTask]
certificationTasks Certification{[(String, DL m ())]
Maybe (NoLockedFundsProof m)
Maybe (NoLockedFundsProofLight m)
Maybe Whitelist
Maybe (Instance CrashTolerance m)
Maybe (CoverageRef -> TestTree)
CoverageIndex
certDLTests :: forall m. Certification m -> [(String, DL m ())]
certUnitTests :: forall m. Certification m -> Maybe (CoverageRef -> TestTree)
certWhitelist :: forall m. Certification m -> Maybe Whitelist
certCrashTolerance :: forall m. Certification m -> Maybe (Instance CrashTolerance m)
certNoLockedFundsLight :: forall m. Certification m -> Maybe (NoLockedFundsProofLight m)
certNoLockedFunds :: forall m. Certification m -> Maybe (NoLockedFundsProof m)
certCoverageIndex :: forall m. Certification m -> CoverageIndex
certDLTests :: [(String, DL m ())]
certUnitTests :: Maybe (CoverageRef -> TestTree)
certWhitelist :: Maybe Whitelist
certCrashTolerance :: Maybe (Instance CrashTolerance m)
certNoLockedFundsLight :: Maybe (NoLockedFundsProofLight m)
certNoLockedFunds :: Maybe (NoLockedFundsProof m)
certCoverageIndex :: CoverageIndex
..} = (CertificationTask -> Bool)
-> [CertificationTask] -> [CertificationTask]
forall a. (a -> Bool) -> [a] -> [a]
filter CertificationTask -> Bool
run [CertificationTask
forall a. Bounded a => a
minBound..CertificationTask
forall a. Bounded a => a
maxBound]
  where
    run :: CertificationTask -> Bool
run CertificationTask
UnitTestsTask          = Maybe (CoverageRef -> TestTree) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (CoverageRef -> TestTree)
certUnitTests
    run CertificationTask
StandardPropertyTask   = Bool
True
    -- run DoubleSatisfactionTask = True
    run CertificationTask
NoLockedFundsTask      = Maybe (NoLockedFundsProof m) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NoLockedFundsProof m)
certNoLockedFunds
    run CertificationTask
NoLockedFundsLightTask = Maybe (NoLockedFundsProofLight m) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (NoLockedFundsProofLight m)
certNoLockedFundsLight
    run CertificationTask
CrashToleranceTask     = Maybe (Instance CrashTolerance m) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Instance CrashTolerance m)
certCrashTolerance
    run CertificationTask
WhitelistTask          = Maybe Whitelist -> Bool
forall a. Maybe a -> Bool
isJust Maybe Whitelist
certWhitelist
    run CertificationTask
DLTestsTask            = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(String, DL m ())] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, DL m ())]
certDLTests

data CertificationOptions = CertificationOptions { CertificationOptions -> Int
certOptNumTests  :: Int
                                                 , CertificationOptions -> Bool
certOptOutput    :: Bool
                                                 , CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel :: Maybe (Chan CertificationEvent)
                                                 }

defaultCertificationOptions :: CertificationOptions
defaultCertificationOptions :: CertificationOptions
defaultCertificationOptions = CertificationOptions :: Int
-> Bool -> Maybe (Chan CertificationEvent) -> CertificationOptions
CertificationOptions { certOptOutput :: Bool
certOptOutput = Bool
True
                                                   , certOptNumTests :: Int
certOptNumTests = Int
100
                                                   , certEventChannel :: Maybe (Chan CertificationEvent)
certEventChannel = Maybe (Chan CertificationEvent)
forall a. Maybe a
Nothing }

type CertMonad = WriterT CoverageReport IO

liftIORep :: IO (CoverageReport, a) -> CertMonad a
liftIORep :: IO (CoverageReport, a) -> CertMonad a
liftIORep IO (CoverageReport, a)
io = do
  (CoverageReport
rep, a
a) <- IO (CoverageReport, a)
-> WriterT CoverageReport IO (CoverageReport, a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (CoverageReport, a)
io
  CoverageReport -> WriterT CoverageReport IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell CoverageReport
rep
  a -> CertMonad a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

runCertMonad :: CertMonad (CertificationReport m) -> IO (CertificationReport m)
runCertMonad :: CertMonad (CertificationReport m) -> IO (CertificationReport m)
runCertMonad CertMonad (CertificationReport m)
m = do
  (CertificationReport m
rep, CoverageReport
cov) <- CertMonad (CertificationReport m)
-> IO (CertificationReport m, CoverageReport)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT CertMonad (CertificationReport m)
m
  CertificationReport m -> IO (CertificationReport m)
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificationReport m -> IO (CertificationReport m))
-> CertificationReport m -> IO (CertificationReport m)
forall a b. (a -> b) -> a -> b
$ CertificationReport m
rep CertificationReport m
-> (CertificationReport m -> CertificationReport m)
-> CertificationReport m
forall a b. a -> (a -> b) -> b
& (CoverageReport -> Identity CoverageReport)
-> CertificationReport m -> Identity (CertificationReport m)
forall m m.
Lens
  (CertificationReport m)
  (CertificationReport m)
  CoverageReport
  CoverageReport
certRes_coverageReport ((CoverageReport -> Identity CoverageReport)
 -> CertificationReport m -> Identity (CertificationReport m))
-> (CoverageReport -> CoverageReport)
-> CertificationReport m
-> CertificationReport m
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (CoverageReport -> CoverageReport -> CoverageReport
forall a. Semigroup a => a -> a -> a
<> CoverageReport
cov)

addOnTestEvents :: Testable prop => CertificationOptions -> prop -> Property
addOnTestEvents :: CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts prop
prop
  | Just Chan CertificationEvent
ch <- CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel CertificationOptions
opts = (Result -> Result) -> prop -> Property
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult (Chan CertificationEvent -> Result -> Result
addCallback Chan CertificationEvent
ch) prop
prop
  | Bool
otherwise                        = prop -> Property
forall prop. Testable prop => prop -> Property
property prop
prop
  where
    addCallback :: Chan CertificationEvent -> Result -> Result
addCallback Chan CertificationEvent
ch Result
r = Result
r { callbacks :: [Callback]
callbacks = Callback
cb Callback -> [Callback] -> [Callback]
forall a. a -> [a] -> [a]
: Result -> [Callback]
callbacks Result
r }
      where cb :: Callback
cb = CallbackKind -> (State -> Result -> IO ()) -> Callback
PostTest CallbackKind
NotCounterexample ((State -> Result -> IO ()) -> Callback)
-> (State -> Result -> IO ()) -> Callback
forall a b. (a -> b) -> a -> b
$ \ State
_st Result
res -> Chan CertificationEvent -> CertificationEvent -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan CertificationEvent
ch (CertificationEvent -> IO ()) -> CertificationEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> CertificationEvent
QuickCheckTestEvent (Result -> Maybe Bool
ok Result
res)

runStandardProperty :: forall m. ContractModel m => CertificationOptions -> CoverageIndex -> CertMonad QC.Result
runStandardProperty :: CertificationOptions -> CoverageIndex -> CertMonad Result
runStandardProperty CertificationOptions
opts CoverageIndex
covIdx = IO (CoverageReport, Result) -> CertMonad Result
forall a. IO (CoverageReport, a) -> CertMonad a
liftIORep (IO (CoverageReport, Result) -> CertMonad Result)
-> IO (CoverageReport, Result) -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ Args
-> CoverageOptions
-> (CoverageOptions -> Property)
-> IO (CoverageReport, Result)
forall prop.
Testable prop =>
Args
-> CoverageOptions
-> (CoverageOptions -> prop)
-> IO (CoverageReport, Result)
quickCheckWithCoverageAndResult
                                  (CertificationOptions -> Args
mkQCArgs CertificationOptions
opts)
                                  (ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
-> CoverageIndex -> CoverageOptions -> CoverageOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
Lens' CoverageOptions CoverageIndex
coverageIndex CoverageIndex
covIdx CoverageOptions
defaultCoverageOptions)
                                ((CoverageOptions -> Property) -> IO (CoverageReport, Result))
-> (CoverageOptions -> Property) -> IO (CoverageReport, Result)
forall a b. (a -> b) -> a -> b
$ \ CoverageOptions
covopts -> CertificationOptions -> (Actions m -> Property) -> Property
forall prop.
Testable prop =>
CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts ((Actions m -> Property) -> Property)
-> (Actions m -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                                               CheckOptions
-> CoverageOptions
-> (ModelState m -> TracePredicate)
-> Actions m
-> Property
forall state.
ContractModel state =>
CheckOptions
-> CoverageOptions
-> (ModelState state -> TracePredicate)
-> Actions state
-> Property
propRunActionsWithOptions
                                                 @m
                                                 CheckOptions
defaultCheckOptionsContractModel
                                                 CoverageOptions
covopts
                                                 (\ ModelState m
_ -> Bool -> TracePredicate
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)

-- TODO: turn on when double satisfaction is re-implemented
-- checkDS :: forall m. ContractModel m => CertificationOptions -> CoverageIndex -> CertMonad QC.Result
-- checkDS opts covIdx = liftIORep $ quickCheckWithCoverageAndResult
--                                   (mkQCArgs opts)
--                                   (set coverageIndex covIdx defaultCoverageOptions)
--                                 $ \ covopts -> addOnTestEvents opts $
--                                                checkDoubleSatisfactionWithOptions
--                                                  @m
--                                                  defaultCheckOptionsContractModel
--                                                  covopts

checkNoLockedFunds :: ContractModel m => CertificationOptions -> NoLockedFundsProof m -> CertMonad QC.Result
checkNoLockedFunds :: CertificationOptions -> NoLockedFundsProof m -> CertMonad Result
checkNoLockedFunds CertificationOptions
opts NoLockedFundsProof m
prf = IO Result -> CertMonad Result
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Result -> CertMonad Result) -> IO Result -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult
                                       (CertificationOptions -> Args
mkQCArgs CertificationOptions
opts)
                                       (Property -> IO Result) -> Property -> IO Result
forall a b. (a -> b) -> a -> b
$ CertificationOptions -> Property -> Property
forall prop.
Testable prop =>
CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ NoLockedFundsProof m -> Property
forall model.
CheckableContractModel model =>
NoLockedFundsProof model -> Property
checkNoLockedFundsProof NoLockedFundsProof m
prf

checkNoLockedFundsLight :: ContractModel m => CertificationOptions -> NoLockedFundsProofLight m -> CertMonad QC.Result
checkNoLockedFundsLight :: CertificationOptions
-> NoLockedFundsProofLight m -> CertMonad Result
checkNoLockedFundsLight CertificationOptions
opts NoLockedFundsProofLight m
prf =
  IO Result -> CertMonad Result
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Result -> CertMonad Result) -> IO Result -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult
          (CertificationOptions -> Args
mkQCArgs CertificationOptions
opts)
          (Property -> IO Result) -> Property -> IO Result
forall a b. (a -> b) -> a -> b
$ CertificationOptions -> Property -> Property
forall prop.
Testable prop =>
CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ NoLockedFundsProofLight m -> Property
forall model.
CheckableContractModel model =>
NoLockedFundsProofLight model -> Property
checkNoLockedFundsProofLight NoLockedFundsProofLight m
prf

mkQCArgs :: CertificationOptions -> Args
mkQCArgs :: CertificationOptions -> Args
mkQCArgs CertificationOptions{Bool
Int
Maybe (Chan CertificationEvent)
certEventChannel :: Maybe (Chan CertificationEvent)
certOptOutput :: Bool
certOptNumTests :: Int
certEventChannel :: CertificationOptions -> Maybe (Chan CertificationEvent)
certOptOutput :: CertificationOptions -> Bool
certOptNumTests :: CertificationOptions -> Int
..} = Args
stdArgs { chatty :: Bool
chatty = Bool
certOptOutput , maxSuccess :: Int
maxSuccess = Int
certOptNumTests }

runUnitTests :: (CoverageRef -> Tasty.TestTree) -> CertMonad [Tasty.Result]
runUnitTests :: (CoverageRef -> TestTree) -> CertMonad [Result]
runUnitTests CoverageRef -> TestTree
t = IO (CoverageReport, [Result]) -> CertMonad [Result]
forall a. IO (CoverageReport, a) -> CertMonad a
liftIORep (IO (CoverageReport, [Result]) -> CertMonad [Result])
-> IO (CoverageReport, [Result]) -> CertMonad [Result]
forall a b. (a -> b) -> a -> b
$ do
    CoverageRef
ref <- IO CoverageRef
newCoverageRef
    [Result]
res <- OptionSet
-> TestTree
-> (StatusMap -> IO (Time -> IO [Result]))
-> IO [Result]
forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
Tasty.launchTestTree OptionSet
forall a. Monoid a => a
mempty (CoverageRef -> TestTree
t CoverageRef
ref) ((StatusMap -> IO (Time -> IO [Result])) -> IO [Result])
-> (StatusMap -> IO (Time -> IO [Result])) -> IO [Result]
forall a b. (a -> b) -> a -> b
$ \ StatusMap
status -> do
      [Result]
rs <- STM [Result] -> IO [Result]
forall a. STM a -> IO a
atomically (STM [Result] -> IO [Result]) -> STM [Result] -> IO [Result]
forall a b. (a -> b) -> a -> b
$ (TVar Status -> STM Result) -> [TVar Status] -> STM [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TVar Status -> STM Result
waitForDone (StatusMap -> [TVar Status]
forall a. IntMap a -> [a]
IntMap.elems StatusMap
status)
      (Time -> IO [Result]) -> IO (Time -> IO [Result])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO [Result]) -> IO (Time -> IO [Result]))
-> (Time -> IO [Result]) -> IO (Time -> IO [Result])
forall a b. (a -> b) -> a -> b
$ \ Time
_ -> [Result] -> IO [Result]
forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
rs
    CoverageData
cov <- CoverageRef -> IO CoverageData
readCoverageRef CoverageRef
ref
    (CoverageReport, [Result]) -> IO (CoverageReport, [Result])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverageIndex -> CoverageData -> CoverageReport
CoverageReport CoverageIndex
forall a. Monoid a => a
mempty CoverageData
cov, [Result]
res)
  where
    waitForDone :: TVar Status -> STM Result
waitForDone TVar Status
tv = do
      Status
s <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tv
      case Status
s of
        Tasty.Done Result
r -> Result -> STM Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
        Status
_            -> STM Result
forall a. STM a
retry

checkDerived :: forall d m c. (c m => ContractModel (d m))
             => Maybe (Instance c m)
             -> CertificationOptions
             -> CertificationTask
             -> CoverageIndex
             -> CertMonad (Maybe QC.Result)
checkDerived :: Maybe (Instance c m)
-> CertificationOptions
-> CertificationTask
-> CoverageIndex
-> CertMonad (Maybe Result)
checkDerived Maybe (Instance c m)
Nothing CertificationOptions
_ CertificationTask
_ CoverageIndex
_                    = Maybe Result -> CertMonad (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Result
forall a. Maybe a
Nothing
checkDerived (Just Instance c m
Instance) CertificationOptions
opts CertificationTask
task CoverageIndex
covIdx =
  Result -> Maybe Result
forall a. a -> Maybe a
Just (Result -> Maybe Result)
-> CertMonad Result -> CertMonad (Maybe Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
task (CertificationOptions -> CoverageIndex -> CertMonad Result
forall m.
ContractModel m =>
CertificationOptions -> CoverageIndex -> CertMonad Result
runStandardProperty @(d m) CertificationOptions
opts CoverageIndex
covIdx)

checkWhitelist :: forall m. ContractModel m
               => Maybe Whitelist
               -> CertificationOptions
               -> CoverageIndex
               -> CertMonad (Maybe QC.Result)
checkWhitelist :: Maybe Whitelist
-> CertificationOptions
-> CoverageIndex
-> CertMonad (Maybe Result)
checkWhitelist Maybe Whitelist
Nothing CertificationOptions
_ CoverageIndex
_           = Maybe Result -> CertMonad (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Result
forall a. Maybe a
Nothing
checkWhitelist (Just Whitelist
wl) CertificationOptions
opts CoverageIndex
covIdx = do
  Result
a <- CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
WhitelistTask
     (CertMonad Result -> CertMonad Result)
-> CertMonad Result -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ IO (CoverageReport, Result) -> CertMonad Result
forall a. IO (CoverageReport, a) -> CertMonad a
liftIORep (IO (CoverageReport, Result) -> CertMonad Result)
-> IO (CoverageReport, Result) -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ Args
-> CoverageOptions
-> (CoverageOptions -> Property)
-> IO (CoverageReport, Result)
forall prop.
Testable prop =>
Args
-> CoverageOptions
-> (CoverageOptions -> prop)
-> IO (CoverageReport, Result)
quickCheckWithCoverageAndResult
                  (CertificationOptions -> Args
mkQCArgs CertificationOptions
opts)
                  (ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
-> CoverageIndex -> CoverageOptions -> CoverageOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
Lens' CoverageOptions CoverageIndex
coverageIndex CoverageIndex
covIdx CoverageOptions
defaultCoverageOptions)
                  ((CoverageOptions -> Property) -> IO (CoverageReport, Result))
-> (CoverageOptions -> Property) -> IO (CoverageReport, Result)
forall a b. (a -> b) -> a -> b
$ \ CoverageOptions
covopts -> CertificationOptions -> (Actions m -> Property) -> Property
forall prop.
Testable prop =>
CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts ((Actions m -> Property) -> Property)
-> (Actions m -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
                                 CheckOptions
-> CoverageOptions -> Whitelist -> Actions m -> Property
forall m.
ContractModel m =>
CheckOptions
-> CoverageOptions -> Whitelist -> Actions m -> Property
checkErrorWhitelistWithOptions @m
                                    CheckOptions
defaultCheckOptionsContractModel
                                    CoverageOptions
covopts Whitelist
wl
  Maybe Result -> CertMonad (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
a)

checkDLTests :: forall m. ContractModel m
            => [(String, DL m ())]
            -> CertificationOptions
            -> CoverageIndex
            -> CertMonad [(String, QC.Result)]
checkDLTests :: [(String, DL m ())]
-> CertificationOptions
-> CoverageIndex
-> CertMonad [(String, Result)]
checkDLTests [] CertificationOptions
_ CoverageIndex
_ = [(String, Result)] -> CertMonad [(String, Result)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
checkDLTests [(String, DL m ())]
tests CertificationOptions
opts CoverageIndex
covIdx =
  CertificationOptions
-> CertificationTask
-> ([(String, Result)] -> Bool)
-> CertMonad [(String, Result)]
-> CertMonad [(String, Result)]
forall r.
CertificationOptions
-> CertificationTask -> (r -> Bool) -> CertMonad r -> CertMonad r
wrapTask CertificationOptions
opts CertificationTask
DLTestsTask (((String, Result) -> Bool) -> [(String, Result)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.all (Result -> Bool
QC.isSuccess (Result -> Bool)
-> ((String, Result) -> Result) -> (String, Result) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Result) -> Result
forall a b. (a, b) -> b
snd))
  (CertMonad [(String, Result)] -> CertMonad [(String, Result)])
-> CertMonad [(String, Result)] -> CertMonad [(String, Result)]
forall a b. (a -> b) -> a -> b
$ [WriterT CoverageReport IO (String, Result)]
-> CertMonad [(String, Result)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(String
s,) (Result -> (String, Result))
-> CertMonad Result -> WriterT CoverageReport IO (String, Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (CoverageReport, Result) -> CertMonad Result
forall a. IO (CoverageReport, a) -> CertMonad a
liftIORep (Args
-> CoverageOptions
-> (CoverageOptions -> Property)
-> IO (CoverageReport, Result)
forall prop.
Testable prop =>
Args
-> CoverageOptions
-> (CoverageOptions -> prop)
-> IO (CoverageReport, Result)
quickCheckWithCoverageAndResult
                                    (CertificationOptions -> Args
mkQCArgs CertificationOptions
opts)
                                    (ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
-> CoverageIndex -> CoverageOptions -> CoverageOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter CoverageOptions CoverageOptions CoverageIndex CoverageIndex
Lens' CoverageOptions CoverageIndex
coverageIndex CoverageIndex
covIdx CoverageOptions
defaultCoverageOptions)
                                    ((CoverageOptions -> Property) -> IO (CoverageReport, Result))
-> (CoverageOptions -> Property) -> IO (CoverageReport, Result)
forall a b. (a -> b) -> a -> b
$ \ CoverageOptions
covopts ->
                                        CertificationOptions -> Property -> Property
forall prop.
Testable prop =>
CertificationOptions -> prop -> Property
addOnTestEvents CertificationOptions
opts (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                                        DL m ()
-> (Actions (WithInstances (WrappedState m)) -> Property)
-> Property
forall state p.
(ContractModel state, Testable p) =>
DL state () -> (Actions state -> p) -> Property
forAllDL DL m ()
dl (CheckOptions
-> CoverageOptions
-> (ModelState m -> TracePredicate)
-> Actions (WithInstances (WrappedState m))
-> Property
forall state.
ContractModel state =>
CheckOptions
-> CoverageOptions
-> (ModelState state -> TracePredicate)
-> Actions state
-> Property
propRunActionsWithOptions
                                                      @m
                                                      CheckOptions
defaultCheckOptionsContractModel
                                                      CoverageOptions
covopts (TracePredicate -> ModelState m -> TracePredicate
forall a b. a -> b -> a
const (TracePredicate -> ModelState m -> TracePredicate)
-> TracePredicate -> ModelState m -> TracePredicate
forall a b. (a -> b) -> a -> b
$ Bool -> TracePredicate
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)))
             | (String
s, DL m ()
dl) <- [(String, DL m ())]
tests ]

startTaskEvent :: CertificationOptions -> CertificationTask -> CertMonad ()
startTaskEvent :: CertificationOptions
-> CertificationTask -> WriterT CoverageReport IO ()
startTaskEvent CertificationOptions
opts CertificationTask
task | Just Chan CertificationEvent
ch <- CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel CertificationOptions
opts = IO () -> WriterT CoverageReport IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT CoverageReport IO ())
-> IO () -> WriterT CoverageReport IO ()
forall a b. (a -> b) -> a -> b
$ Chan CertificationEvent -> CertificationEvent -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan CertificationEvent
ch (CertificationEvent -> IO ()) -> CertificationEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificationTask -> CertificationEvent
StartCertificationTask CertificationTask
task
                         | Bool
otherwise                        = () -> WriterT CoverageReport IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

finishTaskEvent :: CertificationOptions -> Bool -> CertMonad ()
finishTaskEvent :: CertificationOptions -> Bool -> WriterT CoverageReport IO ()
finishTaskEvent CertificationOptions
opts Bool
res | Just Chan CertificationEvent
ch <- CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel CertificationOptions
opts = IO () -> WriterT CoverageReport IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT CoverageReport IO ())
-> IO () -> WriterT CoverageReport IO ()
forall a b. (a -> b) -> a -> b
$ Chan CertificationEvent -> CertificationEvent -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan CertificationEvent
ch (CertificationEvent -> IO ()) -> CertificationEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> CertificationEvent
FinishedTask Bool
res
                         | Bool
otherwise                        = () -> WriterT CoverageReport IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

numTestsEvent :: CertificationOptions -> CertMonad ()
numTestsEvent :: CertificationOptions -> WriterT CoverageReport IO ()
numTestsEvent CertificationOptions
opts | Just Chan CertificationEvent
ch <- CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel CertificationOptions
opts = IO () -> WriterT CoverageReport IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT CoverageReport IO ())
-> IO () -> WriterT CoverageReport IO ()
forall a b. (a -> b) -> a -> b
$ Chan CertificationEvent -> CertificationEvent -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan CertificationEvent
ch (CertificationEvent -> IO ()) -> CertificationEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> CertificationEvent
QuickCheckNumTestsEvent (Int -> CertificationEvent) -> Int -> CertificationEvent
forall a b. (a -> b) -> a -> b
$ CertificationOptions -> Int
certOptNumTests CertificationOptions
opts
                   | Bool
otherwise                        = () -> WriterT CoverageReport IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

certify :: forall m. ContractModel m => Certification m -> IO (CertificationReport m)
certify :: Certification m -> IO (CertificationReport m)
certify = CertificationOptions
-> Certification m -> IO (CertificationReport m)
forall m.
ContractModel m =>
CertificationOptions
-> Certification m -> IO (CertificationReport m)
certifyWithOptions CertificationOptions
defaultCertificationOptions

wrapTask :: CertificationOptions
         -> CertificationTask
         -> (r -> Bool)
         -> CertMonad r
         -> CertMonad r
wrapTask :: CertificationOptions
-> CertificationTask -> (r -> Bool) -> CertMonad r -> CertMonad r
wrapTask CertificationOptions
opts CertificationTask
task r -> Bool
resInterp CertMonad r
act = do
  CertificationOptions
-> CertificationTask -> WriterT CoverageReport IO ()
startTaskEvent CertificationOptions
opts CertificationTask
task
  r
res <- CertMonad r
act
  CertificationOptions -> Bool -> WriterT CoverageReport IO ()
finishTaskEvent CertificationOptions
opts (Bool -> WriterT CoverageReport IO ())
-> Bool -> WriterT CoverageReport IO ()
forall a b. (a -> b) -> a -> b
$ r -> Bool
resInterp r
res
  r -> CertMonad r
forall (m :: * -> *) a. Monad m => a -> m a
return r
res

wrapQCTask :: CertificationOptions
           -> CertificationTask
           -> CertMonad QC.Result
           -> CertMonad QC.Result
wrapQCTask :: CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
task CertMonad Result
m = CertificationOptions
-> CertificationTask
-> (Result -> Bool)
-> CertMonad Result
-> CertMonad Result
forall r.
CertificationOptions
-> CertificationTask -> (r -> Bool) -> CertMonad r -> CertMonad r
wrapTask CertificationOptions
opts CertificationTask
task Result -> Bool
QC.isSuccess (CertMonad Result -> CertMonad Result)
-> CertMonad Result -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ CertificationOptions -> WriterT CoverageReport IO ()
numTestsEvent CertificationOptions
opts WriterT CoverageReport IO ()
-> CertMonad Result -> CertMonad Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CertMonad Result
m

certifyWithOptions :: forall m. ContractModel m
                   => CertificationOptions
                   -> Certification m
                   -> IO (CertificationReport m)
certifyWithOptions :: CertificationOptions
-> Certification m -> IO (CertificationReport m)
certifyWithOptions CertificationOptions
opts Certification{[(String, DL m ())]
Maybe (NoLockedFundsProof m)
Maybe (NoLockedFundsProofLight m)
Maybe Whitelist
Maybe (Instance CrashTolerance m)
Maybe (CoverageRef -> TestTree)
CoverageIndex
certDLTests :: [(String, DL m ())]
certUnitTests :: Maybe (CoverageRef -> TestTree)
certWhitelist :: Maybe Whitelist
certCrashTolerance :: Maybe (Instance CrashTolerance m)
certNoLockedFundsLight :: Maybe (NoLockedFundsProofLight m)
certNoLockedFunds :: Maybe (NoLockedFundsProof m)
certCoverageIndex :: CoverageIndex
certDLTests :: forall m. Certification m -> [(String, DL m ())]
certUnitTests :: forall m. Certification m -> Maybe (CoverageRef -> TestTree)
certWhitelist :: forall m. Certification m -> Maybe Whitelist
certCrashTolerance :: forall m. Certification m -> Maybe (Instance CrashTolerance m)
certNoLockedFundsLight :: forall m. Certification m -> Maybe (NoLockedFundsProofLight m)
certNoLockedFunds :: forall m. Certification m -> Maybe (NoLockedFundsProof m)
certCoverageIndex :: forall m. Certification m -> CoverageIndex
..} = CertMonad (CertificationReport m) -> IO (CertificationReport m)
forall m.
CertMonad (CertificationReport m) -> IO (CertificationReport m)
runCertMonad (CertMonad (CertificationReport m) -> IO (CertificationReport m))
-> CertMonad (CertificationReport m) -> IO (CertificationReport m)
forall a b. (a -> b) -> a -> b
$ do
  -- Unit tests
  [Result]
unitTests    <- CertificationOptions
-> CertificationTask
-> ([Result] -> Bool)
-> CertMonad [Result]
-> CertMonad [Result]
forall r.
CertificationOptions
-> CertificationTask -> (r -> Bool) -> CertMonad r -> CertMonad r
wrapTask CertificationOptions
opts CertificationTask
UnitTestsTask ((Result -> Bool) -> [Result] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.all Result -> Bool
Tasty.resultSuccessful)
                (CertMonad [Result] -> CertMonad [Result])
-> CertMonad [Result] -> CertMonad [Result]
forall a b. (a -> b) -> a -> b
$ [Result] -> Maybe [Result] -> [Result]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Result] -> [Result])
-> WriterT CoverageReport IO (Maybe [Result]) -> CertMonad [Result]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoverageRef -> TestTree) -> CertMonad [Result])
-> Maybe (CoverageRef -> TestTree)
-> WriterT CoverageReport IO (Maybe [Result])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CoverageRef -> TestTree) -> CertMonad [Result]
runUnitTests Maybe (CoverageRef -> TestTree)
certUnitTests
  -- Standard property
  Result
qcRes        <- CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
StandardPropertyTask
                (CertMonad Result -> CertMonad Result)
-> CertMonad Result -> CertMonad Result
forall a b. (a -> b) -> a -> b
$ CertificationOptions -> CoverageIndex -> CertMonad Result
forall m.
ContractModel m =>
CertificationOptions -> CoverageIndex -> CertMonad Result
runStandardProperty @m CertificationOptions
opts CoverageIndex
certCoverageIndex
  -- TODO: fixme when double sat done
  -- Double satisfaction
  -- dsRes        <- wrapQCTask opts DoubleSatisfactionTask
  --               $ checkDS @m opts certCoverageIndex
  -- No locked funds
  Maybe Result
noLock       <- (NoLockedFundsProof m -> CertMonad Result)
-> Maybe (NoLockedFundsProof m) -> CertMonad (Maybe Result)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
NoLockedFundsTask (CertMonad Result -> CertMonad Result)
-> (NoLockedFundsProof m -> CertMonad Result)
-> NoLockedFundsProof m
-> CertMonad Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificationOptions -> NoLockedFundsProof m -> CertMonad Result
forall m.
ContractModel m =>
CertificationOptions -> NoLockedFundsProof m -> CertMonad Result
checkNoLockedFunds CertificationOptions
opts)
                           Maybe (NoLockedFundsProof m)
certNoLockedFunds
  -- No locked funds light
  Maybe Result
noLockLight  <- (NoLockedFundsProofLight m -> CertMonad Result)
-> Maybe (NoLockedFundsProofLight m) -> CertMonad (Maybe Result)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (CertificationOptions
-> CertificationTask -> CertMonad Result -> CertMonad Result
wrapQCTask CertificationOptions
opts CertificationTask
NoLockedFundsLightTask (CertMonad Result -> CertMonad Result)
-> (NoLockedFundsProofLight m -> CertMonad Result)
-> NoLockedFundsProofLight m
-> CertMonad Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CertificationOptions
-> NoLockedFundsProofLight m -> CertMonad Result
forall m.
ContractModel m =>
CertificationOptions
-> NoLockedFundsProofLight m -> CertMonad Result
checkNoLockedFundsLight CertificationOptions
opts)
                           Maybe (NoLockedFundsProofLight m)
certNoLockedFundsLight
  -- Crash tolerance
  Maybe Result
ctRes        <- Maybe (Instance CrashTolerance m)
-> CertificationOptions
-> CertificationTask
-> CoverageIndex
-> CertMonad (Maybe Result)
forall (d :: * -> *) m (c :: * -> Constraint).
(c m => ContractModel (d m)) =>
Maybe (Instance c m)
-> CertificationOptions
-> CertificationTask
-> CoverageIndex
-> CertMonad (Maybe Result)
checkDerived @WithCrashTolerance Maybe (Instance CrashTolerance m)
certCrashTolerance CertificationOptions
opts CertificationTask
CrashToleranceTask CoverageIndex
certCoverageIndex
  -- Whitelist
  Maybe Result
wlRes        <- Maybe Whitelist
-> CertificationOptions
-> CoverageIndex
-> CertMonad (Maybe Result)
forall m.
ContractModel m =>
Maybe Whitelist
-> CertificationOptions
-> CoverageIndex
-> CertMonad (Maybe Result)
checkWhitelist @m Maybe Whitelist
certWhitelist CertificationOptions
opts CoverageIndex
certCoverageIndex
  -- DL tests
  [(String, Result)]
dlRes        <- [(String, DL m ())]
-> CertificationOptions
-> CoverageIndex
-> CertMonad [(String, Result)]
forall m.
ContractModel m =>
[(String, DL m ())]
-> CertificationOptions
-> CoverageIndex
-> CertMonad [(String, Result)]
checkDLTests @m [(String, DL m ())]
certDLTests CertificationOptions
opts CoverageIndex
certCoverageIndex
  case CertificationOptions -> Maybe (Chan CertificationEvent)
certEventChannel CertificationOptions
opts of
    Just Chan CertificationEvent
ch -> IO () -> WriterT CoverageReport IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> WriterT CoverageReport IO ())
-> IO () -> WriterT CoverageReport IO ()
forall a b. (a -> b) -> a -> b
$ Chan CertificationEvent -> CertificationEvent -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan CertificationEvent
ch CertificationEvent
CertificationDone
    Maybe (Chan CertificationEvent)
Nothing -> () -> WriterT CoverageReport IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  -- Final results
  CertificationReport m -> CertMonad (CertificationReport m)
forall (m :: * -> *) a. Monad m => a -> m a
return (CertificationReport m -> CertMonad (CertificationReport m))
-> CertificationReport m -> CertMonad (CertificationReport m)
forall a b. (a -> b) -> a -> b
$ CertificationReport :: forall m.
Result
-> Maybe Result
-> Maybe Result
-> Maybe Result
-> [Result]
-> CoverageReport
-> Maybe Bool
-> Maybe Result
-> [(String, Result)]
-> CertificationReport m
CertificationReport
            { _certRes_standardPropertyResult :: Result
_certRes_standardPropertyResult       = Result
qcRes
            -- , _certRes_doubleSatisfactionResult     = dsRes
            , _certRes_standardCrashToleranceResult :: Maybe Result
_certRes_standardCrashToleranceResult = Maybe Result
ctRes
            , _certRes_noLockedFundsResult :: Maybe Result
_certRes_noLockedFundsResult          = Maybe Result
noLock
            , _certRes_noLockedFundsLightResult :: Maybe Result
_certRes_noLockedFundsLightResult     = Maybe Result
noLockLight
            , _certRes_unitTestResults :: [Result]
_certRes_unitTestResults              = [Result]
unitTests
            , _certRes_coverageReport :: CoverageReport
_certRes_coverageReport               = CoverageIndex -> CoverageData -> CoverageReport
CoverageReport CoverageIndex
certCoverageIndex CoverageData
forall a. Monoid a => a
mempty
            , _certRes_whitelistOk :: Maybe Bool
_certRes_whitelistOk                  = Whitelist -> Bool
whitelistOk (Whitelist -> Bool) -> Maybe Whitelist -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Whitelist
certWhitelist
            , _certRes_whitelistResult :: Maybe Result
_certRes_whitelistResult              = Maybe Result
wlRes
            , _certRes_DLTests :: [(String, Result)]
_certRes_DLTests                      = [(String, Result)]
dlRes }