{-# 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. ([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 basic tests, you don’t need to import "Distribution.TestSuite".
module Distribution.TestSuite.QuickCheck
  ( -- * Create tests
    getPropertyTest,
    getPropertyTestWith,
    getPropertyTestUsing,
    getPropertyTestWithUsing,
    getPropertyTests,
    propertyTestGroup,

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

    -- * Functions for using arguments
    argsToTestArgs,
    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' q v = bool max min q v $ bool id pred q 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 :: QC.Args -> TestArgs
argsToTestArgs QC.Args {..} =
  TestArgs
    { verbosity = if chatty then Chatty else Silent,
      verboseShrinking = False,
      maxDiscardRatio,
      noShrinking = False,
      maxShrinks,
      maxSuccess,
      maxSize,
      sizeScale = 1
    }

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

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

useModifiers :: QC.Testable a => TestArgs -> a -> QC.Property
useModifiers 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))
        ]

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

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 to before giving up or zero to disable shrinking",
        optionType = positiveIntType,
        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
      }
  ]

-- | 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
  }

-- | 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
          { -- TODO Consider using 'T.Progress' to allow intermediate results
            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"
                      ++ "\n"
                      ++ show result,
            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

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

-- | 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

-- | 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