{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- NoFieldSelectors is implemented in GHC 9.2.2, but HLS doesn’t support it
-- {-# LANGUAGE NoFieldSelectors #-}

-- |
-- Module:       Distribution.TestSuite.QuickCheck
-- Description:  Convert QuickCheck properties into Cabal tests
-- Copyright:    ⓒ Anselm Schüler 2022
-- License:      MIT
-- Maintainer:   Anselm Schüler <mail@anselmschueler.com>
-- Stability:    stable
-- Portability:  Portable
--
-- This module allows you to easily make Cabal tests for the @detailed-0.9@ interface. See the [docs](https://cabal.readthedocs.io/en/3.6/cabal-package.html#example-package-using-detailed-0-9-interface).
-- It sets sensible option declarations for the tests.
--
-- This module re-uses record names from "Distribution.TestSuite" and "Test.QuickCheck".
-- It is recommended that you enable the [@DisambiguateRecordFields@](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/disambiguate_record_fields.html) extension in GHC and/or import the module qualified.
-- For many basic tests, you don’t need to import "Distribution.TestSuite".
--
-- To make a test, simply construct a 'PropertyTest' and call 'getPropertyTest' on it.
--
-- A simple sample test suite:
--
-- @
-- module Tests (tests) where
-- import "Distribution.TestSuite.QuickCheck"
-- import "Test.QuickCheck"
-- tests = [
--   'getPropertyTest' 'PropertyTest' {
--     'name' = /"addition-is-commutative"/,
--     'tags' = [],
--     'property' = \\a b -> a + b 'QC.===' b + a
--     }
--   ]
-- @
--
-- The tests you get as a result support several parameters:
--
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | Property name      | Valid values | Effect                                                                          |
-- +====================+==============+=================================================================================+
-- | @silent@           | Booleans     | If true, all output is disabled.                                                |
-- |                    |              | Sets 'verbosity' to 'Silent'. See 'QC.chatty'.                                  |
-- |                    |              | Disabling Silent raises the verbosity to Chatty if it is not already higher.    |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @chatty@           | Booleans     | If true, the default amount of output is emitted by QuickCheck.                 |
-- |                    |              | Sets 'verbosity' to 'Chatty'. See 'QC.chatty'.                                  |
-- |                    |              | Note that setting this verbosity option to false does not undo setting it to    |
-- |                    |              | true, but lowers the verbosity by one level if it is not already lower.         |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @verbose@          | Booleans     | If true, prints checked values as output.                                       |
-- |                    |              | Sets 'verbosity' to 'Verbose'. See 'QC.verbose'.                                |
-- |                    |              | Note that setting this verbosity option to false does not undo setting it to    |
-- |                    |              | true, but lowers the verbosity by one level if it is not already lower.         |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @verboseShrinking@ | Booleans     | If true, prints all checked and shrunk values as output.                        |
-- |                    |              | See 'QC.verboseShrinking'.                                                      |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @verbosity@        | @Silent@,    | Sets the 'verbosity' to the desired level.                                      |
-- |                    | @Chatty@,    |                                                                                 |
-- |                    | or @Verbose@ |                                                                                 |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @maxDiscardRatio@  | positive     | Maximum number of discarded tests per successful test before giving up.         |
-- |                    | integer      | See 'QC.maxDiscardRatio'.                                                       |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @noShrinking@      | Booleans     | Disables shrinking of test cases.                                               |
-- |                    |              | See 'QC.noShrinking'.                                                           |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @shrinking@        | Booleans     | Opposite of @noShrinking@.                                                      |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @maxShrinks@       | nonnegative  | Maximum number of shrinks before giving up or zero to disable shrinking.        |
-- |                    | integer      | See 'QC.maxShrinks'.                                                            |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @maxSuccess@       | positive     | Maximum number of successful tests before succeeding.                           |
-- |                    | integer      | See 'QC.maxSuccess'.                                                            |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @maxSize@          | positive     | Size to use for the biggest test cases.                                         |
-- |                    | integer      | See 'QC.maxSize'.                                                               |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
-- | @sizeScale@        | positive     | Scales all sizes by a number.                                                   |
-- |                    | integer      | See 'QC.mapSize'.                                                               |
-- +--------------------+--------------+---------------------------------------------------------------------------------+
--
-- You can set default values by using 'getPropertyTestWith'
-- You can access these values in your test by using 'getPropertyTestUsing'.
-- Do both with 'getPropertyTestWithUsing'.
module Distribution.TestSuite.QuickCheck
  ( -- * Create tests
    getPropertyTest,
    getPropertyTestWith,
    getPropertyTestUsing,
    getPropertyTestWithUsing,
    getPropertyTests,
    propertyTestGroup,

    -- * Argument data types
    PropertyTest (..),
    TestArgs (..),
    Verbosity (..),

    -- * Functions for using arguments
    argsToTestArgs,
    argsToTestArgsWith,
    testArgsToArgs,
    stdTestArgs,
  )
where

import Data.Bool (bool)
import Data.Functor ((<&>))
import qualified Distribution.TestSuite as T
import qualified Test.QuickCheck as QC
import Text.Read (readMaybe)

-- | Datatype for setting the verbosity of tests
data Verbosity
  = -- | QuickCheck prints nothing. This sets @'QC.chatty' = 'False'@.
    Silent
  | -- | Print basic statistics. This sets @'QC.chatty' = 'True'@.
    Chatty
  | -- | Print every test case. This applies 'QC.verbose'.
    Verbose
  deriving
    ( Eq,
      -- | 'Silent' < 'Chatty' < 'Verbose'
      Ord,
      Show,
      Read,
      Enum,
      Bounded
    )

-- ! [PARTIAL] This function fails when passed Silent
switchVerbosity :: Verbosity -> Bool -> Verbosity -> Verbosity
switchVerbosity v' True v = v'
switchVerbosity v' False v = min (pred v') v

-- | Arguments for altering property test behaviour.
--   These can be altered in the final Cabal 'T.Test' using 'T.setOption'.
data TestArgs = TestArgs
  { -- | Verbosity for tests. See 'QC.verbose' and 'QC.chatty'.
    verbosity :: Verbosity,
    -- TODO Consider joining verboseShrinking back into verbosity

    -- | Whether QuickCheck should print shrinks. See 'QC.verboseShrinking'.
    verboseShrinking :: Bool,
    -- | Maximum discarded tests per successful test. See 'QC.maxDiscardRatio'.
    maxDiscardRatio :: Int,
    -- | Disable shrinking. See 'QC.noShrinking'.
    noShrinking :: Bool,
    -- | Maximum number of shrink attempts. See 'QC.maxShrinks'.
    maxShrinks :: Int,
    -- | Maximum number of successful checks before passing. See 'QC.maxSuccess'.
    maxSuccess :: Int,
    -- | Maximum size of test cases. See 'QC.maxSize'.
    maxSize :: Int,
    -- | Scale size by an integer using 'QC.mapSize'.
    sizeScale :: Int
  }

-- | Transform a QuickCheck 'QC.Args' value to a 'TestArgs' value, defaulting all missing properties
--
--   @'argsToTestArgs' = 'argsToTestArgsWith' 'stdTestArgs'@
argsToTestArgs :: QC.Args -> TestArgs
argsToTestArgs = argsToTestArgsWith stdTestArgs

-- | Transform a QuickCheck 'QC.Args' value to a 'TestArgs' value, with fallbacks for missing properties given by the first argument.
argsToTestArgsWith :: TestArgs -> QC.Args -> TestArgs
argsToTestArgsWith testArgs QC.Args {..} =
  testArgs
    { verbosity = if chatty then Chatty else Silent,
      maxDiscardRatio,
      maxShrinks,
      maxSuccess,
      maxSize
    }

-- | Recover arguments passed to 'QC.quickCheck' from a 'TestArgs'
testArgsToArgs :: TestArgs -> QC.Args
testArgsToArgs TestArgs {..} =
  QC.Args
    { replay = Nothing,
      maxSuccess,
      maxDiscardRatio,
      maxSize,
      chatty = verbosity >= Chatty,
      maxShrinks
    }

-- | Default arguments for property tests
stdTestArgs :: TestArgs
stdTestArgs = argsToTestArgs QC.stdArgs

switchVIn :: Verbosity -> Bool -> TestArgs -> TestArgs
switchVIn v' q args@TestArgs {verbosity} = args {verbosity = switchVerbosity v' q verbosity}

setArgStr :: String -> String -> Maybe (TestArgs -> TestArgs)
setArgStr "silent" str =
  readMaybe str <&> \val args@TestArgs {verbosity} ->
    if val
      then args {verbosity = Silent}
      else args {verbosity = max Chatty verbosity}
setArgStr "chatty" str = readMaybe str <&> switchVIn Chatty
setArgStr "verbose" str = readMaybe str <&> switchVIn Verbose
setArgStr "verboseShrinking" str =
  readMaybe str <&> \val args ->
    args {verboseShrinking = val}
setArgStr "verbosity" str =
  readMaybe str <&> \val args ->
    args {verbosity = val}
setArgStr "maxDiscardRatio" str =
  readMaybe str <&> \val args ->
    args {maxDiscardRatio = val}
setArgStr "noShrinking" str =
  readMaybe str <&> \val args ->
    args {noShrinking = val}
setArgStr "shrinking" str =
  readMaybe str <&> \val args ->
    args {noShrinking = not val}
setArgStr "maxShrinks" str =
  readMaybe str <&> \val args ->
    args {maxShrinks = val}
setArgStr "maxSuccess" str =
  readMaybe str <&> \val args ->
    args {maxSuccess = val}
setArgStr "maxSize" str =
  readMaybe str <&> \val args ->
    args {maxSize = val}
setArgStr "sizeScale" str =
  readMaybe str <&> \val args ->
    args {sizeScale = val}
setArgStr _ _ = Nothing

positiveIntType :: T.OptionType
positiveIntType =
  T.OptionNumber
    { optionNumberIsInt = True,
      optionNumberBounds = (Just "1", Nothing)
    }

getOptionDescrs :: TestArgs -> [T.OptionDescr]
getOptionDescrs TestArgs {..} =
  [ T.OptionDescr
      { optionName = "silent",
        optionDescription = "Suppress QuickCheck output",
        optionType = T.OptionBool,
        optionDefault = Just . show $ verbosity == Silent
      },
    T.OptionDescr
      { optionName = "chatty",
        optionDescription = "Print QuickCheck output",
        optionType = T.OptionBool,
        optionDefault = Just . show $ verbosity > Chatty
      },
    T.OptionDescr
      { optionName = "verbose",
        optionDescription = "Print checked values",
        optionType = T.OptionBool,
        optionDefault = Just . show $ verbosity > Verbose
      },
    T.OptionDescr
      { optionName = "verboseShrinking",
        optionDescription = "Print all checked and shrunk values",
        optionType = T.OptionBool,
        optionDefault = Just . show $ verboseShrinking
      },
    T.OptionDescr
      { optionName = "verbosity",
        optionDescription = "Verbosity level",
        optionType = T.OptionEnum ["Silent", "Chatty", "Verbose", "VerboseShrinking"],
        optionDefault = Just $ show verbosity
      },
    T.OptionDescr
      { optionName = "maxDiscardRatio",
        optionDescription = "Maximum number of discarded tests per successful test before giving up",
        optionType = positiveIntType,
        optionDefault = Just $ show maxDiscardRatio
      },
    T.OptionDescr
      { optionName = "noShrinking",
        optionDescription = "Disable shrinking",
        optionType = T.OptionBool,
        optionDefault = Just $ show noShrinking
      },
    T.OptionDescr
      { optionName = "shrinking",
        optionDescription = "Enable shrinking",
        optionType = T.OptionBool,
        optionDefault = Just . show $ not noShrinking
      },
    T.OptionDescr
      { optionName = "maxShrinks",
        optionDescription = "Maximum number of shrinks before giving up or zero to disable shrinking",
        optionType =
          T.OptionNumber
            { optionNumberIsInt = True,
              optionNumberBounds = (Just "0", Nothing)
            },
        optionDefault = Just $ show maxShrinks
      },
    T.OptionDescr
      { optionName = "maxSuccess",
        optionDescription = "Maximum number of successful tests before succeeding",
        optionType = positiveIntType,
        optionDefault = Just $ show maxSuccess
      },
    T.OptionDescr
      { optionName = "maxSize",
        optionDescription = "Size to use for the biggest test cases",
        optionType = positiveIntType,
        optionDefault = Just $ show maxSize
      },
    T.OptionDescr
      { optionName = "sizeScale",
        optionDescription = "Scale all sizes by a number",
        optionType = positiveIntType,
        optionDefault = Just $ show sizeScale
      }
  ]

getModifiers :: QC.Testable a => TestArgs -> a -> QC.Property
getModifiers TestArgs {verbosity, noShrinking, verboseShrinking, sizeScale} =
  foldr (.) QC.property $
    snd
      <$> filter
        fst
        [ (verbosity == Verbose, QC.verbose),
          (verboseShrinking, QC.verboseShrinking),
          (noShrinking, QC.noShrinking),
          (sizeScale /= 1, QC.mapSize (* sizeScale))
        ]

-- | Property test declaration with metadata
data PropertyTest prop = PropertyTest
  { -- | Name of the test, for Cabal. See See Cabal’s 'T.name'.
    name :: String,
    -- | Tags of the test, for Cabal. See Cabal’s 'T.tags'.
    tags :: [String],
    -- | Property to check. This should usually be or return an instance of 'QC.Testable'.
    property :: prop
  }

qcTestArgs :: QC.Testable a => TestArgs -> a -> IO QC.Result
qcTestArgs args property = QC.quickCheckWithResult (testArgsToArgs args) (getModifiers args property)

-- | Get a Cabal 'T.Test' with custom 'TestArgs' from a 'PropertyTest' that takes the test arguments and returns a 'QC.testable' value
getPropertyTestWithUsing ::
  QC.Testable prop =>
  -- | The arguments for the test
  TestArgs ->
  -- | A property test whose 'property' takes a 'TestArgs' argument
  PropertyTest (TestArgs -> prop) ->
  T.Test
getPropertyTestWithUsing originalArgs PropertyTest {..} =
  let withArgs args =
        T.TestInstance
          { run = do
              result <- qcTestArgs args (property args)
              let resultStr = "\n" ++ show result
              return $ T.Finished case result of
                QC.Success {} -> T.Pass
                QC.GaveUp {} ->
                  T.Error $ "GaveUp: QuickCheck gave up" ++ resultStr
                QC.Failure {} ->
                  T.Fail $ "Failure: A property failed" ++ resultStr
                QC.NoExpectedFailure {} ->
                  T.Fail $ "NoExpectedFailure: A property that should have failed did not" ++ resultStr,
            name,
            tags,
            options = getOptionDescrs originalArgs,
            setOption = \opt str -> case setArgStr opt str of
              Nothing -> Left "Parse error"
              Just f -> Right . withArgs $ f args
          }
   in T.Test $ withArgs originalArgs

-- | Get a Cabal 'T.Test' from a 'PropertyTest' that takes the test arguments and returns a 'QC.Testable' value
getPropertyTestUsing ::
  QC.Testable prop =>
  -- | A property test whose 'property' takes a 'TestArgs' argument
  PropertyTest (TestArgs -> prop) ->
  T.Test
getPropertyTestUsing = getPropertyTestWithUsing stdTestArgs

discardingTestArgs :: PropertyTest prop -> PropertyTest (TestArgs -> prop)
discardingTestArgs test@PropertyTest {property} = test {property = const property}

-- | Get a Cabal 'T.Test' from a 'PropertyTest' with custom 'TestArgs'
getPropertyTestWith ::
  QC.Testable prop =>
  -- | The arguments for the test
  TestArgs ->
  PropertyTest prop ->
  T.Test
getPropertyTestWith args = getPropertyTestWithUsing args . discardingTestArgs

-- | Get a Cabal 'T.Test' from a 'PropertyTest'
getPropertyTest :: QC.Testable prop => PropertyTest prop -> T.Test
getPropertyTest = getPropertyTestWithUsing stdTestArgs . discardingTestArgs

-- | Get a list of 'T.Test's from a list of 'PropertyTest's
getPropertyTests :: QC.Testable prop => [PropertyTest prop] -> [T.Test]
getPropertyTests = (getPropertyTest <$>)

-- | Get a named test group from a list of 'PropertyTest's. These are assumed to be able to run in parallel. See 'T.testGroup' and 'T.Group'.
propertyTestGroup :: QC.Testable prop => String -> [PropertyTest prop] -> T.Test
propertyTestGroup name = T.testGroup name . getPropertyTests