{-# LANGUAGE NamedFieldPuns #-}

module Convex.Tasty.Streaming.QCStats (
  QCStatsKey (..),
  QCStatsStore,
  QCStatsRecorder (..),
  QCStatsStoreOption (..),
  newQCStatsStore,
  storeQCStatsRecorder,
  mkQCStatsKey,
  lookupQCStats,
  lookupQCStatsByTestInfo,
  recordQCStatsFromState,
) where

import Convex.Tasty.Streaming.SrcLoc (SrcLocRange (..))
import Convex.Tasty.Streaming.Types (
  MonitoringClassStat (..),
  MonitoringLabelStat (..),
  MonitoringStats (..),
  MonitoringTableEntry (..),
  MonitoringTableStat (..),
  TestInfo (..),
 )
import Data.Foldable (for_)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.List (sortOn)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Ord (Down (..))
import Data.Tagged (Tagged (..))
import Data.Text qualified as T
import Test.QuickCheck.State qualified as QS
import Test.Tasty.Options (IsOption (..))

data QCStatsKey = QCStatsKey
  { QCStatsKey -> SrcLocRange
qskSrcLoc :: SrcLocRange
  , QCStatsKey -> Text
qskTestName :: T.Text
  }
  deriving (QCStatsKey -> QCStatsKey -> Bool
(QCStatsKey -> QCStatsKey -> Bool)
-> (QCStatsKey -> QCStatsKey -> Bool) -> Eq QCStatsKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QCStatsKey -> QCStatsKey -> Bool
== :: QCStatsKey -> QCStatsKey -> Bool
$c/= :: QCStatsKey -> QCStatsKey -> Bool
/= :: QCStatsKey -> QCStatsKey -> Bool
Eq, Eq QCStatsKey
Eq QCStatsKey =>
(QCStatsKey -> QCStatsKey -> Ordering)
-> (QCStatsKey -> QCStatsKey -> Bool)
-> (QCStatsKey -> QCStatsKey -> Bool)
-> (QCStatsKey -> QCStatsKey -> Bool)
-> (QCStatsKey -> QCStatsKey -> Bool)
-> (QCStatsKey -> QCStatsKey -> QCStatsKey)
-> (QCStatsKey -> QCStatsKey -> QCStatsKey)
-> Ord QCStatsKey
QCStatsKey -> QCStatsKey -> Bool
QCStatsKey -> QCStatsKey -> Ordering
QCStatsKey -> QCStatsKey -> QCStatsKey
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
$ccompare :: QCStatsKey -> QCStatsKey -> Ordering
compare :: QCStatsKey -> QCStatsKey -> Ordering
$c< :: QCStatsKey -> QCStatsKey -> Bool
< :: QCStatsKey -> QCStatsKey -> Bool
$c<= :: QCStatsKey -> QCStatsKey -> Bool
<= :: QCStatsKey -> QCStatsKey -> Bool
$c> :: QCStatsKey -> QCStatsKey -> Bool
> :: QCStatsKey -> QCStatsKey -> Bool
$c>= :: QCStatsKey -> QCStatsKey -> Bool
>= :: QCStatsKey -> QCStatsKey -> Bool
$cmax :: QCStatsKey -> QCStatsKey -> QCStatsKey
max :: QCStatsKey -> QCStatsKey -> QCStatsKey
$cmin :: QCStatsKey -> QCStatsKey -> QCStatsKey
min :: QCStatsKey -> QCStatsKey -> QCStatsKey
Ord, Int -> QCStatsKey -> ShowS
[QCStatsKey] -> ShowS
QCStatsKey -> String
(Int -> QCStatsKey -> ShowS)
-> (QCStatsKey -> String)
-> ([QCStatsKey] -> ShowS)
-> Show QCStatsKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QCStatsKey -> ShowS
showsPrec :: Int -> QCStatsKey -> ShowS
$cshow :: QCStatsKey -> String
show :: QCStatsKey -> String
$cshowList :: [QCStatsKey] -> ShowS
showList :: [QCStatsKey] -> ShowS
Show)

newtype QCStatsStore = QCStatsStore (IORef (Map QCStatsKey MonitoringStats))

newtype QCStatsRecorder = QCStatsRecorder
  { QCStatsRecorder -> QCStatsKey -> MonitoringStats -> IO ()
qcRecordStats :: QCStatsKey -> MonitoringStats -> IO ()
  }

newtype QCStatsStoreOption = QCStatsStoreOption (Maybe QCStatsStore)

instance IsOption QCStatsRecorder where
  defaultValue :: QCStatsRecorder
defaultValue = (QCStatsKey -> MonitoringStats -> IO ()) -> QCStatsRecorder
QCStatsRecorder (\QCStatsKey
_ MonitoringStats
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  parseValue :: String -> Maybe QCStatsRecorder
parseValue = Maybe QCStatsRecorder -> String -> Maybe QCStatsRecorder
forall a b. a -> b -> a
const Maybe QCStatsRecorder
forall a. Maybe a
Nothing
  optionName :: Tagged QCStatsRecorder String
optionName = String -> Tagged QCStatsRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"qc-stats-recorder"
  optionHelp :: Tagged QCStatsRecorder String
optionHelp = String -> Tagged QCStatsRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: quickcheck monitoring stats recorder"

instance IsOption QCStatsStoreOption where
  defaultValue :: QCStatsStoreOption
defaultValue = Maybe QCStatsStore -> QCStatsStoreOption
QCStatsStoreOption Maybe QCStatsStore
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe QCStatsStoreOption
parseValue = Maybe QCStatsStoreOption -> String -> Maybe QCStatsStoreOption
forall a b. a -> b -> a
const Maybe QCStatsStoreOption
forall a. Maybe a
Nothing
  optionName :: Tagged QCStatsStoreOption String
optionName = String -> Tagged QCStatsStoreOption String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"qc-stats-store"
  optionHelp :: Tagged QCStatsStoreOption String
optionHelp = String -> Tagged QCStatsStoreOption String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: quickcheck monitoring stats store handle"

newQCStatsStore :: IO QCStatsStore
newQCStatsStore :: IO QCStatsStore
newQCStatsStore = IORef (Map QCStatsKey MonitoringStats) -> QCStatsStore
QCStatsStore (IORef (Map QCStatsKey MonitoringStats) -> QCStatsStore)
-> IO (IORef (Map QCStatsKey MonitoringStats)) -> IO QCStatsStore
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map QCStatsKey MonitoringStats
-> IO (IORef (Map QCStatsKey MonitoringStats))
forall a. a -> IO (IORef a)
newIORef Map QCStatsKey MonitoringStats
forall k a. Map k a
Map.empty

storeQCStatsRecorder :: QCStatsStore -> QCStatsRecorder
storeQCStatsRecorder :: QCStatsStore -> QCStatsRecorder
storeQCStatsRecorder (QCStatsStore IORef (Map QCStatsKey MonitoringStats)
ref) = (QCStatsKey -> MonitoringStats -> IO ()) -> QCStatsRecorder
QCStatsRecorder ((QCStatsKey -> MonitoringStats -> IO ()) -> QCStatsRecorder)
-> (QCStatsKey -> MonitoringStats -> IO ()) -> QCStatsRecorder
forall a b. (a -> b) -> a -> b
$ \QCStatsKey
key MonitoringStats
stats ->
  IORef (Map QCStatsKey MonitoringStats)
-> (Map QCStatsKey MonitoringStats
    -> (Map QCStatsKey MonitoringStats, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map QCStatsKey MonitoringStats)
ref ((Map QCStatsKey MonitoringStats
  -> (Map QCStatsKey MonitoringStats, ()))
 -> IO ())
-> (Map QCStatsKey MonitoringStats
    -> (Map QCStatsKey MonitoringStats, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map QCStatsKey MonitoringStats
m -> (QCStatsKey
-> MonitoringStats
-> Map QCStatsKey MonitoringStats
-> Map QCStatsKey MonitoringStats
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert QCStatsKey
key MonitoringStats
stats Map QCStatsKey MonitoringStats
m, ())

lookupQCStats :: QCStatsStore -> QCStatsKey -> IO (Maybe MonitoringStats)
lookupQCStats :: QCStatsStore -> QCStatsKey -> IO (Maybe MonitoringStats)
lookupQCStats (QCStatsStore IORef (Map QCStatsKey MonitoringStats)
ref) QCStatsKey
key =
  QCStatsKey
-> Map QCStatsKey MonitoringStats -> Maybe MonitoringStats
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QCStatsKey
key (Map QCStatsKey MonitoringStats -> Maybe MonitoringStats)
-> IO (Map QCStatsKey MonitoringStats)
-> IO (Maybe MonitoringStats)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map QCStatsKey MonitoringStats)
-> IO (Map QCStatsKey MonitoringStats)
forall a. IORef a -> IO a
readIORef IORef (Map QCStatsKey MonitoringStats)
ref

lookupQCStatsByTestInfo :: QCStatsStore -> TestInfo -> IO (Maybe MonitoringStats)
lookupQCStatsByTestInfo :: QCStatsStore -> TestInfo -> IO (Maybe MonitoringStats)
lookupQCStatsByTestInfo (QCStatsStore IORef (Map QCStatsKey MonitoringStats)
ref) TestInfo
ti =
  case TestInfo -> Maybe SrcLocRange
tiSrcLoc TestInfo
ti of
    Maybe SrcLocRange
Nothing -> Maybe MonitoringStats -> IO (Maybe MonitoringStats)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MonitoringStats
forall a. Maybe a
Nothing
    Just SrcLocRange
loc -> do
      Map QCStatsKey MonitoringStats
m <- IORef (Map QCStatsKey MonitoringStats)
-> IO (Map QCStatsKey MonitoringStats)
forall a. IORef a -> IO a
readIORef IORef (Map QCStatsKey MonitoringStats)
ref
      Maybe MonitoringStats -> IO (Maybe MonitoringStats)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe MonitoringStats -> IO (Maybe MonitoringStats))
-> Maybe MonitoringStats -> IO (Maybe MonitoringStats)
forall a b. (a -> b) -> a -> b
$ QCStatsKey
-> Map QCStatsKey MonitoringStats -> Maybe MonitoringStats
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SrcLocRange -> Text -> QCStatsKey
mkQCStatsKey SrcLocRange
loc (TestInfo -> Text
tiName TestInfo
ti)) Map QCStatsKey MonitoringStats
m

mkQCStatsKey :: SrcLocRange -> T.Text -> QCStatsKey
mkQCStatsKey :: SrcLocRange -> Text -> QCStatsKey
mkQCStatsKey SrcLocRange
loc Text
testName = QCStatsKey{qskSrcLoc :: SrcLocRange
qskSrcLoc = SrcLocRange
loc, qskTestName :: Text
qskTestName = Text
testName}

recordQCStatsFromState :: QCStatsRecorder -> Maybe SrcLocRange -> String -> QS.State -> IO ()
recordQCStatsFromState :: QCStatsRecorder -> Maybe SrcLocRange -> String -> State -> IO ()
recordQCStatsFromState QCStatsRecorder
recorder Maybe SrcLocRange
mLoc String
testName State
st =
  Maybe SrcLocRange -> (SrcLocRange -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe SrcLocRange
mLoc ((SrcLocRange -> IO ()) -> IO ())
-> (SrcLocRange -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SrcLocRange
loc ->
    QCStatsRecorder -> QCStatsKey -> MonitoringStats -> IO ()
qcRecordStats QCStatsRecorder
recorder (SrcLocRange -> Text -> QCStatsKey
mkQCStatsKey SrcLocRange
loc (String -> Text
T.pack String
testName)) (State -> MonitoringStats
fromState State
st)

fromState :: QS.State -> MonitoringStats
fromState :: State -> MonitoringStats
fromState State
st =
  MonitoringStats
    { msNumTests :: Int
msNumTests = Int
total
    , msNumDiscarded :: Int
msNumDiscarded = State -> Int
QS.numDiscardedTests State
st
    , msLabels :: [MonitoringLabelStat]
msLabels =
        (MonitoringLabelStat -> Down Int)
-> [MonitoringLabelStat] -> [MonitoringLabelStat]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
          (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> (MonitoringLabelStat -> Int) -> MonitoringLabelStat -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonitoringLabelStat -> Int
mlsCount)
          [ MonitoringLabelStat
              { mlsLabels :: [Text]
mlsLabels = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
names
              , mlsCount :: Int
mlsCount = Int
count
              , mlsPercent :: Double
mlsPercent = Int -> Double
forall {a} {a}. (Fractional a, Integral a) => a -> a
pct Int
count
              }
          | ([String]
names, Int
count) <- Map [String] Int -> [([String], Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map [String] Int
QS.labels State
st)
          ]
    , msClasses :: [MonitoringClassStat]
msClasses =
        (MonitoringClassStat -> Down Int)
-> [MonitoringClassStat] -> [MonitoringClassStat]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
          (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> (MonitoringClassStat -> Int) -> MonitoringClassStat -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonitoringClassStat -> Int
mcsCount)
          [ MonitoringClassStat
              { mcsName :: Text
mcsName = String -> Text
T.pack String
className
              , mcsCount :: Int
mcsCount = Int
count
              , mcsPercent :: Double
mcsPercent = Int -> Double
forall {a} {a}. (Fractional a, Integral a) => a -> a
pct Int
count
              }
          | (String
className, Int
count) <- Map String Int -> [(String, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map String Int
QS.classes State
st)
          ]
    , msTables :: [MonitoringTableStat]
msTables =
        [ MonitoringTableStat
            { mtsName :: Text
mtsName = String -> Text
T.pack String
tableName
            , mtsEntries :: [MonitoringTableEntry]
mtsEntries =
                (MonitoringTableEntry -> Down Int)
-> [MonitoringTableEntry] -> [MonitoringTableEntry]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
                  (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> (MonitoringTableEntry -> Int)
-> MonitoringTableEntry
-> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MonitoringTableEntry -> Int
mteCount)
                  [ MonitoringTableEntry
                      { mteValue :: Text
mteValue = String -> Text
T.pack String
entryName
                      , mteCount :: Int
mteCount = Int
count
                      }
                  | (String
entryName, Int
count) <- Map String Int -> [(String, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String Int
tableEntries
                  ]
            }
        | (String
tableName, Map String Int
tableEntries) <- Map String (Map String Int) -> [(String, Map String Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map String (Map String Int)
QS.tables State
st)
        ]
    }
 where
  total :: Int
total = State -> Int
QS.numSuccessTests State
st
  pct :: a -> a
pct a
count
    | Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = a
0
    | Bool
otherwise = (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count a -> a -> a
forall a. Num a => a -> a -> a
* a
100) a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
total