Silent.hs

{-# OPTIONS_GHC -Wall -Werror #-}

{-# 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 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
    , output       :: !String
      -- ^ Non-printed output
    , reason       :: !String
      -- ^ If the property failed, why?
    }
  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": "…", …, "reason": "…" } }
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 . result_)
  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, result_ 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

result_
  :: QC.Result
  -> Result
result_ 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.output       = o
        , Test.QuickCheck.Silent.reason       = []
        }
    QC.GaveUp t d _ _ _ o ->
      Result
        { status                              = Desisted
        , Test.QuickCheck.Silent.numTests     = t
        , Test.QuickCheck.Silent.numDiscarded = d
        , Test.QuickCheck.Silent.output       = o
        , Test.QuickCheck.Silent.reason       = []
        }
    QC.Failure t d _ _ _ _ _ r _ o _ _ _ _ ->
      Result
        { status                              = Failure
        , Test.QuickCheck.Silent.numTests     = t
        , Test.QuickCheck.Silent.numDiscarded = d
        , Test.QuickCheck.Silent.output       = o
        , Test.QuickCheck.Silent.reason       = r
        }
    QC.NoExpectedFailure t d _ _ _ o ->
      Result
        { status                              = NoFailure
        , Test.QuickCheck.Silent.numTests     = t
        , Test.QuickCheck.Silent.numDiscarded = d
        , Test.QuickCheck.Silent.output       = o
        , Test.QuickCheck.Silent.reason       = []
        }