Silent.hs

{-# OPTIONS_GHC -Wall #-}

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

{-# LANGUAGE DeriveDataTypeable           #-}

{-# LANGUAGE LambdaCase                   #-}

{-# LANGUAGE NumericUnderscores           #-}

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

-- |
-- 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
  , Timeout
  , Separator
  , Pattern
  , Status(..)
  , Result(..)
  , JSON
  , quickCheckSilent
  , quickCheckSilentSuite
  , quickCheckSilentSuiteJSON
  , isSuccess
  )
where

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

import           Data.Data                            ( Data )
import           Data.List                            ( isPrefixOf )
import           Data.Maybe                           ( fromMaybe )
import           System.Timeout                       ( timeout )

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

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

-- | To ensure a computation result is available within @n@ seconds.
type Timeout = Int

-- | A character, for example: @.@ (dot), that separates 'Test' 'Label's for
-- 'Group's and 'Case's.
type Separator = Char

-- | A string containing 'Test' 'Label's for 'Group's and 'Case's as well as the
-- chosen 'Separator' character. For example: @"Test.QuickCheck.Silent"@.
type Pattern = String

-- | 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 'Result's,
-- without printing them to 'System.IO.stdout', in case 'Result's are available
-- before the 'Timeout' (seconds) expires. If no 'Timeout' value is provided, a
-- default value of @60@ seconds will be used. If a computation timed-out, an
-- empty list will be provided.
quickCheckSilent
  :: Maybe Timeout
  -> [SilentProp]
  -> IO [Result]
quickCheckSilent mto sps =
  ( \ case
      Just rs -> rs
      Nothing -> []
  )
  <$> timeout oto (mapM (\ p -> resultAux <$> (aux . property) p) sps)
  where
    oto = 1_000_000 * fromMaybe 60 mto
    aux =
      QC.quickCheckWithResult $ stdArgs { chatty = False }

-- | Tests a suite of silent properties, producing a list of 'Result's with
-- their respective 'Label's and without printing them to 'System.IO.stdout', in
-- case 'Result's are available before the 'Timeout' (seconds) expires. If no
-- 'Timeout' value is provided, a default value of @60@ seconds will be used. If
-- a computation timed-out, an empty list will be provided.
--
-- For example,
--
-- > check =
-- >   quickCheckSilentSuite oto sep pts tcs
-- >   where
-- >     oto = Just 60 -- seconds
-- >     sep = '.'
-- >     pts = [ "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's, will be checked if they are a 'Data.List.isPrefixOf'
-- of each 'Label':
--
-- > any (`isPrefixOf` label) [ pattern_0, pattern_1, … pattern_n ]
--
-- @NOTE@: To test all cases, just provide a singleton list with an empty string
-- element as 'Pattern's as it's a prefix for all possible 'Label's.
quickCheckSilentSuite
  :: Maybe Timeout
  -> Separator
  -> [Pattern]
  -> Test
  -> IO [(Label, Result)]
quickCheckSilentSuite mto sep pts suite =
  ( \ case
      Just rs -> rs
      Nothing -> []
  )
  <$> timeout oto
    ( mapM
        ( \ (l, sp) ->
            (aux . property) sp >>= \ r ->
            pure (l, resultAux r)
        )
      $ filter ( \(l, _) -> any  (`isPrefixOf` l) pts)
      $ dfs [] suite
    )
  where
    oto = 1_000_000 * fromMaybe 60 mto
    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 list of 'JSON'
-- data payloads instead.
quickCheckSilentSuiteJSON
  :: Maybe Timeout
  -> Separator
  -> [Pattern]
  -> Test
  -> IO [JSON]
quickCheckSilentSuiteJSON mto sep pts suite =
  map
  ( \ (l, r) ->
      encodeJSON $ LabelResultJSON l r
  )
  <$> quickCheckSilentSuite mto sep pts 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   = maybe [] 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   = []
        }