Silent.hs

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe                         #-}

{-# LANGUAGE DeriveDataTypeable           #-}

--------------------------------------------------------------------------------

-- |
-- Copyright  : (c) 2026 SPISE MISU ApS
-- License    : LGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability  : experimental
--
-- Testing with QuickCheck in silence

--------------------------------------------------------------------------------

module Test.QuickCheck.Silent
  ( -- * Declaring tests
    Test (Case, Group)
  , Label
    -- * Property without IO
  , SilentProp ()
  , property
  , silent
  , withNumTests
    -- * Running tests
  , JSON
  , Status(..)
  , Result(..)
  , quickCheckSilent
  , quickCheckSilentSuite
  , quickCheckSilentSuiteJSON
  , isSuccess
  )
where

--------------------------------------------------------------------------------

import           Data.Data                            ( Data )
import           Data.List                            ( isPrefixOf )
import           Data.Maybe                           ( fromMaybe )

import qualified Test.QuickCheck                      as QC
import           Test.QuickCheck
  ( Property
  , Testable
  , chatty
  , stdArgs
  )

import           Internal.GaloisInc.Text.JSON.Generic ( encodeJSON )

--------------------------------------------------------------------------------

-- | A `Testable` silent property.
newtype SilentProp =
  SilentProp
    { property :: Property
      -- ^ Unwrap the the silent property.
    }

--------------------------------------------------------------------------------

-- | A name or description for a case or a subtree of the @Test@s.
type Label = String

-- | The basic structure used to create an annotated tree of test cases.
data Test
  -- | A set of @Test@s sharing the same level in the hierarchy.
  = Group !Label ![Test]
  -- | A single, independent test case composed.
  | Case  !Label !SilentProp

--------------------------------------------------------------------------------

-- | Status represents the outcome of a test
data Status
  -- | A successful test run
  = Success
  -- | A failed test run
  | Failure
  -- | Given up
  | Desisted
  -- | A property that should have failed did not
  | NoFailure
  deriving (Data, Show)

-- | Result represents the test result
data Result =
  Result
    { status         :: !Status
      -- ^ Outcome of the test
    , numTests       :: !Int
      -- ^ Number of tests performed
    , numDiscarded   :: !Int
      -- ^ Number of tests skipped
    , numShrinks     :: !Int
      -- ^ Number of successful shrinking steps performed
    , numShrinkTries :: !Int
      -- ^ Number of unsuccessful shrinking steps performed
    , numShrinkFinal :: !Int
      -- ^ Number of unsuccessful shrinking steps performed since last successful shrink
    , usedSeed       :: !String
      -- ^ What seed was used
    , usedSize       :: !Int
      -- ^ What was the test size
    , output         :: !String
      -- ^ Non-printed output
    , reason         :: !String
      -- ^ If the property failed, why?
    , theException   :: !String
      -- ^ The exception the property threw, if any
    }
  deriving (Data, Show)

data LabelResultJSON =
  LabelResultJSON
    { label  :: !Label
    , result :: !Result
    }
  deriving (Data, Show)

-- | A 'JSON' payload string that represents the test 'Result' with its
-- respective 'Label'
--
-- > { "label": "…", "result": { "status": "…", …, "theException": "…" } }
type JSON = String

--------------------------------------------------------------------------------

-- | Convert a `Testable` thing, without 'System.IO.IO' effects, to a silent
-- property.
silent
  :: Testable prop
  => prop
  -> SilentProp
silent =
  SilentProp . QC.property

-- | Configures how many times a silent property will be tested.
--
-- For example,
--
-- > quickCheckSilent [withNumTests 1000 p]
--
-- will test @p@ up to 1000 times.
withNumTests
  :: Testable prop
  => Int
  -> prop
  -> SilentProp
withNumTests n =
  SilentProp . QC.withNumTests n

--------------------------------------------------------------------------------

-- | Tests a sequence of silent properties, producing a list of results, without
-- printing them to 'System.IO.stdout'.
quickCheckSilent
  :: [SilentProp]
  -> IO [Result]
quickCheckSilent =
  mapM (\ p -> (aux . property) p >>= pure . resultAux)
  where
    aux =
      QC.quickCheckWithResult $ stdArgs { chatty = False }

-- | Tests a suite of silent properties, producing a list of results with their
-- respective labels and without printing them to 'System.IO.stdout'.
--
-- For example,
--
-- > check =
-- >   quickCheckSilentSuite sep pat tcs
-- >   where
-- >     sep = '.'
-- >     pat = "Test.QuickCheck.Silent"
-- >     tcs =
-- >       Group "Test"
-- >         [ Group "QuickCheck"
-- >           [ Group "Silent"
-- >             [ Case "foo" (withNumTests  100 p)
-- >             , Case "bar" (withNumTests 1000 q)
-- >             ]
-- >           , Group "OtherModule"
-- >             [ Case "baz" (withNumTests   10 r)
-- >             ]
-- >           ]
-- >         ]
--
-- will test both @p@ and @q@, but not @r@.
--
-- The provided @pattern@, will be checked if it 'Data.List.isPrefixOf' of each
-- @label@:
--
-- > pattern `isPrefixOf` label
--
-- @NOTE@: To test all cases, just provide an empty string as @pattern@ as it's
-- a prefix for all possible @labels@.
quickCheckSilentSuite
  :: Char
  -> String
  -> Test
  -> IO [(Label, Result)]
quickCheckSilentSuite sep pat suite =
  mapM
    ( \ (l, sp) ->
        (aux . property) sp >>= \ r ->
        pure (l, resultAux r)
    )
  $ filter ( \(l, _) -> pat `isPrefixOf` l)
  $ dfs [] suite
  where
    dfs [ ] (Group l ts) = concatMap (dfs (                l)) ts
    dfs acc (Group l ts) = concatMap (dfs (acc ++ [sep] ++ l)) ts
    dfs [ ] (Case  l p)  = [              (                l, p)]
    dfs acc (Case  l p)  = [              (acc ++ [sep] ++ l, p)]
    aux =
      QC.quickCheckWithResult $ stdArgs { chatty = False }

-- | Same behavior as 'quickCheckSilentSuite', but, producing a 'JSON' data
-- payload instead.
quickCheckSilentSuiteJSON
  :: Char
  -> String
  -> Test
  -> IO [JSON]
quickCheckSilentSuiteJSON sep pat suite =
  ( \ lrs ->
      map
      ( \ (l, r) ->
          encodeJSON $ LabelResultJSON l r
      )
      lrs
  )
  <$> quickCheckSilentSuite sep pat suite

-- | Check if the test run result was a success
isSuccess :: Result -> Bool
isSuccess Result { status = Success } = True
isSuccess ___________________________ = False

--------------------------------------------------------------------------------

-- HELPERS

resultAux
  :: QC.Result
  -> Result
resultAux res =
  case res of
    QC.Success t d _ _ _ o ->
      Result
        { status                                = Success
        , Test.QuickCheck.Silent.numTests       = t
        , Test.QuickCheck.Silent.numDiscarded   = d
        , Test.QuickCheck.Silent.numShrinks     = 0
        , Test.QuickCheck.Silent.numShrinkTries = 0
        , Test.QuickCheck.Silent.numShrinkFinal = 0
        , Test.QuickCheck.Silent.usedSeed       = []
        , Test.QuickCheck.Silent.usedSize       = 0
        , Test.QuickCheck.Silent.output         = o
        , Test.QuickCheck.Silent.reason         = []
        , Test.QuickCheck.Silent.theException   = []
        }
    QC.GaveUp t d _ _ _ o ->
      Result
        { status                                = Desisted
        , Test.QuickCheck.Silent.numTests       = t
        , Test.QuickCheck.Silent.numDiscarded   = d
        , Test.QuickCheck.Silent.numShrinks     = 0
        , Test.QuickCheck.Silent.numShrinkTries = 0
        , Test.QuickCheck.Silent.numShrinkFinal = 0
        , Test.QuickCheck.Silent.usedSeed       = []
        , Test.QuickCheck.Silent.usedSize       = 0
        , Test.QuickCheck.Silent.output         = o
        , Test.QuickCheck.Silent.reason         = []
        , Test.QuickCheck.Silent.theException   = []
        }
    QC.Failure t d ss st sf se si r e o _ _ _ _ ->
      Result
        { status                                = Failure
        , Test.QuickCheck.Silent.numTests       = t
        , Test.QuickCheck.Silent.numDiscarded   = d
        , Test.QuickCheck.Silent.numShrinks     = ss
        , Test.QuickCheck.Silent.numShrinkTries = st
        , Test.QuickCheck.Silent.numShrinkFinal = sf
        , Test.QuickCheck.Silent.usedSeed       = show se
        , Test.QuickCheck.Silent.usedSize       = si
        , Test.QuickCheck.Silent.output         = o
        , Test.QuickCheck.Silent.reason         = r
        , Test.QuickCheck.Silent.theException   = fromMaybe [] $ show <$> e
        }
    QC.NoExpectedFailure t d _ _ _ o ->
      Result
        { status                                = NoFailure
        , Test.QuickCheck.Silent.numTests       = t
        , Test.QuickCheck.Silent.numDiscarded   = d
        , Test.QuickCheck.Silent.numShrinks     = 0
        , Test.QuickCheck.Silent.numShrinkTries = 0
        , Test.QuickCheck.Silent.numShrinkFinal = 0
        , Test.QuickCheck.Silent.usedSeed       = []
        , Test.QuickCheck.Silent.usedSize       = 0
        , Test.QuickCheck.Silent.output         = o
        , Test.QuickCheck.Silent.reason         = []
        , Test.QuickCheck.Silent.theException   = []
        }