{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Skeletest.Prop.Internal (
  Property,
  PropertyM,
  runProperty,

  -- * Test
  forAll,
  discard,

  -- * Configuring properties
  setDiscardLimit,
  setShrinkLimit,
  setShrinkRetries,
  setConfidence,
  setVerifiedTermination,
  setTestLimit,

  -- * Coverage
  classify,
  cover,
  label,
  collect,

  -- * CLI flags
  PropSeedFlag,
  PropLimitFlag,
) where

import Control.Monad (ap)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class qualified as Trans
import Control.Monad.Trans.Reader qualified as Trans
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe (catMaybes)
import Data.Text qualified as Text
import GHC.Stack qualified as GHC
import Hedgehog qualified
import Hedgehog.Internal.Property qualified as Hedgehog
import Hedgehog.Internal.Report qualified as Hedgehog hiding (defaultConfig)
import Hedgehog.Internal.Runner qualified as Hedgehog
import Hedgehog.Internal.Seed qualified as Hedgehog.Seed
import Hedgehog.Internal.Source qualified as Hedgehog
import Text.Read (readEither, readMaybe)
import UnliftIO.Exception (throwIO)
import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)

#if !MIN_VERSION_base(4, 20, 0)
import Data.Foldable (foldl')
#endif

import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)
import Skeletest.Internal.TestInfo (getTestInfo)
import Skeletest.Internal.TestRunner (
  AssertionFail (..),
  TestResult (..),
  TestResultMessage (..),
  Testable (..),
  testResultPass,
 )
import Skeletest.Internal.Utils.Color qualified as Color

-- | A property to run, with optional configuration settings specified up front.
--
-- Settings should be specified before any other 'Property' calls; any settings
-- specified afterwards are ignored.
type Property = PropertyM ()

data PropertyM a
  = PropertyPure [PropertyConfig] a
  | PropertyIO [PropertyConfig] (Trans.ReaderT FailureRef (Hedgehog.PropertyT IO) a)

type FailureRef = IORef (Maybe AssertionFail)

instance Functor PropertyM where
  fmap :: forall a b. (a -> b) -> PropertyM a -> PropertyM b
fmap a -> b
f = \case
    PropertyPure [PropertyConfig]
cfg a
a -> [PropertyConfig] -> b -> PropertyM b
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure [PropertyConfig]
cfg (a -> b
f a
a)
    PropertyIO [PropertyConfig]
cfg ReaderT FailureRef (PropertyT IO) a
m -> [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) b -> PropertyM b
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [PropertyConfig]
cfg (a -> b
f (a -> b)
-> ReaderT FailureRef (PropertyT IO) a
-> ReaderT FailureRef (PropertyT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT FailureRef (PropertyT IO) a
m)
instance Applicative PropertyM where
  pure :: forall a. a -> PropertyM a
pure = [PropertyConfig] -> a -> PropertyM a
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure []
  <*> :: forall a b. PropertyM (a -> b) -> PropertyM a -> PropertyM b
(<*>) = PropertyM (a -> b) -> PropertyM a -> PropertyM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad PropertyM where
  PropertyPure [PropertyConfig]
cfg1 a
a >>= :: forall a b. PropertyM a -> (a -> PropertyM b) -> PropertyM b
>>= a -> PropertyM b
k =
    case a -> PropertyM b
k a
a of
      PropertyPure [PropertyConfig]
cfg2 b
b -> [PropertyConfig] -> b -> PropertyM b
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure ([PropertyConfig]
cfg1 [PropertyConfig] -> [PropertyConfig] -> [PropertyConfig]
forall a. Semigroup a => a -> a -> a
<> [PropertyConfig]
cfg2) b
b
      PropertyIO [PropertyConfig]
cfg2 ReaderT FailureRef (PropertyT IO) b
m -> [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) b -> PropertyM b
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO ([PropertyConfig]
cfg1 [PropertyConfig] -> [PropertyConfig] -> [PropertyConfig]
forall a. Semigroup a => a -> a -> a
<> [PropertyConfig]
cfg2) ReaderT FailureRef (PropertyT IO) b
m
  PropertyIO [PropertyConfig]
cfg1 ReaderT FailureRef (PropertyT IO) a
fa >>= a -> PropertyM b
k =
    [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) b -> PropertyM b
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [PropertyConfig]
cfg1 (ReaderT FailureRef (PropertyT IO) b -> PropertyM b)
-> ReaderT FailureRef (PropertyT IO) b -> PropertyM b
forall a b. (a -> b) -> a -> b
$ do
      a <- ReaderT FailureRef (PropertyT IO) a
fa
      case k a of
        PropertyPure [PropertyConfig]
_ b
b -> b -> ReaderT FailureRef (PropertyT IO) b
forall a. a -> ReaderT FailureRef (PropertyT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
        PropertyIO [PropertyConfig]
_ ReaderT FailureRef (PropertyT IO) b
mb -> ReaderT FailureRef (PropertyT IO) b
mb
instance MonadIO PropertyM where
  liftIO :: forall a. IO a -> PropertyM a
liftIO = [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [] (ReaderT FailureRef (PropertyT IO) a -> PropertyM a)
-> (IO a -> ReaderT FailureRef (PropertyT IO) a)
-> IO a
-> PropertyM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT FailureRef (PropertyT IO) a
forall a. IO a -> ReaderT FailureRef (PropertyT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Testable PropertyM where
  runTestable :: PropertyM () -> IO TestResult
runTestable = PropertyM () -> IO TestResult
runProperty
  context :: forall a. [Char] -> PropertyM a -> PropertyM a
context [Char]
msg PropertyM a
m = [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) () -> PropertyM ()
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [] ([Char] -> ReaderT FailureRef (PropertyT IO) ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
Hedgehog.annotate [Char]
msg) PropertyM () -> PropertyM a -> PropertyM a
forall a b. PropertyM a -> PropertyM b -> PropertyM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PropertyM a
m
  throwFailure :: forall a. AssertionFail -> PropertyM a
throwFailure AssertionFail
e = [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [] (ReaderT FailureRef (PropertyT IO) a -> PropertyM a)
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
forall a b. (a -> b) -> a -> b
$ do
    failureRef <- ReaderT FailureRef (PropertyT IO) FailureRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
    writeIORef failureRef (Just e)
    Trans.lift Hedgehog.failure

propConfig :: PropertyConfig -> Property
propConfig :: PropertyConfig -> PropertyM ()
propConfig PropertyConfig
cfg = [PropertyConfig] -> () -> PropertyM ()
forall a. [PropertyConfig] -> a -> PropertyM a
PropertyPure [PropertyConfig
cfg] ()

propM :: Hedgehog.PropertyT IO a -> PropertyM a
propM :: forall a. PropertyT IO a -> PropertyM a
propM = [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [] (ReaderT FailureRef (PropertyT IO) a -> PropertyM a)
-> (PropertyT IO a -> ReaderT FailureRef (PropertyT IO) a)
-> PropertyT IO a
-> PropertyM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyT IO a -> ReaderT FailureRef (PropertyT IO) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT FailureRef m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift

data PropertyConfig
  = DiscardLimit Int
  | ShrinkLimit Int
  | ShrinkRetries Int
  | SetConfidence Int
  | SetVerifiedTermination
  | SetTestLimit Int

resolveConfig :: [PropertyConfig] -> Hedgehog.PropertyConfig
resolveConfig :: [PropertyConfig] -> PropertyConfig
resolveConfig = (PropertyConfig -> PropertyConfig -> PropertyConfig)
-> PropertyConfig -> [PropertyConfig] -> PropertyConfig
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PropertyConfig -> PropertyConfig -> PropertyConfig
go PropertyConfig
defaultConfig
  where
    defaultConfig :: PropertyConfig
defaultConfig =
      Hedgehog.PropertyConfig
        { propertyDiscardLimit :: DiscardLimit
propertyDiscardLimit = DiscardLimit
100
        , propertyShrinkLimit :: ShrinkLimit
propertyShrinkLimit = ShrinkLimit
1000
        , propertyShrinkRetries :: ShrinkRetries
propertyShrinkRetries = ShrinkRetries
0
        , propertyTerminationCriteria :: TerminationCriteria
propertyTerminationCriteria = TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination TestLimit
100
        , propertySkip :: Maybe Skip
propertySkip = Maybe Skip
forall a. Maybe a
Nothing
        }

    go :: PropertyConfig -> PropertyConfig -> PropertyConfig
go PropertyConfig
cfg = \case
      DiscardLimit Int
x -> PropertyConfig
cfg{Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit x}
      ShrinkLimit Int
x -> PropertyConfig
cfg{Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit x}
      ShrinkRetries Int
x -> PropertyConfig
cfg{Hedgehog.propertyShrinkRetries = Hedgehog.ShrinkRetries x}
      SetConfidence Int
x ->
        PropertyConfig
cfg
          { Hedgehog.propertyTerminationCriteria =
              case Hedgehog.propertyTerminationCriteria cfg of
                Hedgehog.NoEarlyTermination Confidence
_ TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
                Hedgehog.NoConfidenceTermination TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
                Hedgehog.EarlyTermination Confidence
_ TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination (Int64 -> Confidence
Hedgehog.Confidence (Int64 -> Confidence) -> Int64 -> Confidence
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) TestLimit
tests
          }
      PropertyConfig
SetVerifiedTermination ->
        PropertyConfig
cfg
          { Hedgehog.propertyTerminationCriteria =
              case Hedgehog.propertyTerminationCriteria cfg of
                Hedgehog.NoEarlyTermination Confidence
c TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c TestLimit
tests
                Hedgehog.NoConfidenceTermination TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
Hedgehog.defaultConfidence TestLimit
tests
                Hedgehog.EarlyTermination Confidence
c TestLimit
tests -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c TestLimit
tests
          }
      SetTestLimit Int
x ->
        PropertyConfig
cfg
          { Hedgehog.propertyTerminationCriteria =
              case Hedgehog.propertyTerminationCriteria cfg of
                Hedgehog.NoEarlyTermination Confidence
c TestLimit
_ -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.NoEarlyTermination Confidence
c (Int -> TestLimit
Hedgehog.TestLimit Int
x)
                Hedgehog.NoConfidenceTermination TestLimit
_ -> TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination (Int -> TestLimit
Hedgehog.TestLimit Int
x)
                Hedgehog.EarlyTermination Confidence
c TestLimit
_ -> Confidence -> TestLimit -> TerminationCriteria
Hedgehog.EarlyTermination Confidence
c (Int -> TestLimit
Hedgehog.TestLimit Int
x)
          }

runProperty :: Property -> IO TestResult
runProperty :: PropertyM () -> IO TestResult
runProperty = \case
  PropertyPure [PropertyConfig]
cfg () -> PropertyM () -> IO TestResult
runProperty (PropertyM () -> IO TestResult) -> PropertyM () -> IO TestResult
forall a b. (a -> b) -> a -> b
$ [PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) () -> PropertyM ()
forall a.
[PropertyConfig]
-> ReaderT FailureRef (PropertyT IO) a -> PropertyM a
PropertyIO [PropertyConfig]
cfg (() -> ReaderT FailureRef (PropertyT IO) ()
forall a. a -> ReaderT FailureRef (PropertyT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  PropertyIO [PropertyConfig]
cfg ReaderT FailureRef (PropertyT IO) ()
m -> do
    failureRef <- Maybe AssertionFail -> IO FailureRef
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Maybe AssertionFail
forall a. Maybe a
Nothing
    (seed, extraConfig) <- loadPropFlags
    report <-
      Hedgehog.checkReport
        (resolveConfig $ cfg <> extraConfig)
        0
        seed
        (Trans.runReaderT m failureRef)
        reportProgress

    let
      Hedgehog.TestCount testCount = Hedgehog.reportTests report
      Hedgehog.DiscardCount discards = Hedgehog.reportDiscards report
      Hedgehog.Coverage coverage = Hedgehog.reportCoverage report

    case Hedgehog.reportStatus report of
      Result
Hedgehog.OK ->
        TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          TestResult
testResultPass
            { testResultMessage =
                TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $
                  [ [show testCount <> " tests, " <> show discards <> " discards"]
                  , renderCoverage coverage testCount
                  ]
            }
      Result
Hedgehog.GaveUp -> do
        testInfo <- IO TestInfo
forall (m :: * -> *). MonadIO m => m TestInfo
getTestInfo
        throwIO
          AssertionFail
            { testInfo
            , testFailMessage =
                Text.pack . List.intercalate "\n" $
                  [ "Gave up after " <> show discards <> " discards."
                  , "Passed " <> show testCount <> " tests."
                  ]
            , testFailContext = []
            , callStack = GHC.fromCallSiteList []
            }
      Hedgehog.Failed Hedgehog.FailureReport{[Char]
[[Char]]
[FailedAnnotation]
Maybe Span
Maybe (Coverage CoverCount)
Maybe Diff
ShrinkPath
ShrinkCount
failureShrinks :: ShrinkCount
failureShrinkPath :: ShrinkPath
failureCoverage :: Maybe (Coverage CoverCount)
failureAnnotations :: [FailedAnnotation]
failureLocation :: Maybe Span
failureMessage :: [Char]
failureDiff :: Maybe Diff
failureFootnotes :: [[Char]]
failureFootnotes :: FailureReport -> [[Char]]
failureDiff :: FailureReport -> Maybe Diff
failureMessage :: FailureReport -> [Char]
failureLocation :: FailureReport -> Maybe Span
failureAnnotations :: FailureReport -> [FailedAnnotation]
failureCoverage :: FailureReport -> Maybe (Coverage CoverCount)
failureShrinkPath :: FailureReport -> ShrinkPath
failureShrinks :: FailureReport -> ShrinkCount
..} ->
        FailureRef -> IO (Maybe AssertionFail)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef FailureRef
failureRef IO (Maybe AssertionFail)
-> (Maybe AssertionFail -> IO TestResult) -> IO TestResult
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe AssertionFail
Nothing -> do
            testInfo <- IO TestInfo
forall (m :: * -> *). MonadIO m => m TestInfo
getTestInfo
            throwIO
              AssertionFail
                { testInfo
                , testFailMessage = Text.pack failureMessage
                , testFailContext = []
                , callStack = toCallStack failureLocation
                }
          Just AssertionFail
failure -> do
            let
              info :: FailContext
info =
                ([Char] -> Text) -> [[Char]] -> FailContext
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
Text.pack ([[Char]] -> FailContext)
-> ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> FailContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> FailContext) -> [[[Char]]] -> FailContext
forall a b. (a -> b) -> a -> b
$
                  [
                    [ [Char]
"Failed after " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
testCount [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" tests."
                    , [Char]
"Rerun with --seed=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Report Result -> [Char]
forall {a}. Report a -> [Char]
renderSeed Report Result
report [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" to reproduce."
                    , [Char]
""
                    ]
                  , [ let loc :: [Char]
loc =
                            case Maybe Span
failedSpan of
                              Just Hedgehog.Span{[Char]
ColumnNo
LineNo
spanFile :: [Char]
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
spanEndColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanStartLine :: Span -> LineNo
spanFile :: Span -> [Char]
..} ->
                                [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
":" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
                                  [ [Char]
spanFile
                                  , Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> (LineNo -> Int) -> LineNo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineNo -> Int
Hedgehog.unLineNo (LineNo -> [Char]) -> LineNo -> [Char]
forall a b. (a -> b) -> a -> b
$ LineNo
spanStartLine
                                  , Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> (ColumnNo -> Int) -> ColumnNo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColumnNo -> Int
Hedgehog.unColumnNo (ColumnNo -> [Char]) -> ColumnNo -> [Char]
forall a b. (a -> b) -> a -> b
$ ColumnNo
spanStartColumn
                                  ]
                              Maybe Span
Nothing -> [Char]
"<unknown loc>"
                       in [Char]
loc [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" ==> " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
failedValue
                    | Hedgehog.FailedAnnotation{[Char]
Maybe Span
failedSpan :: Maybe Span
failedValue :: [Char]
failedValue :: FailedAnnotation -> [Char]
failedSpan :: FailedAnnotation -> Maybe Span
..} <- [FailedAnnotation]
failureAnnotations
                    ]
                  ]

            AssertionFail -> IO TestResult
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO
              AssertionFail
failure
                { testFailContext =
                    -- N.B. testFailContext is reversed!
                    testFailContext failure <> reverse info
                }
  where
    reportProgress :: p -> f ()
reportProgress p
_ = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    renderSeed :: Report a -> [Char]
renderSeed Report a
report =
      let Hedgehog.Seed Word64
value Word64
gamma = Report a -> Seed
forall a. Report a -> Seed
Hedgehog.reportSeed Report a
report
       in Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
value [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
gamma
    renderCoverage :: Map k (Label CoverCount) -> p -> [[Char]]
renderCoverage Map k (Label CoverCount)
coverage p
testCount =
      let columns :: [([Char], [Char], [Char])]
columns =
            [ ([Char]
name, [Char]
percentStr, [Char]
percentBar)
            | Hedgehog.MkLabel{Maybe Span
LabelName
CoverPercentage
CoverCount
labelName :: LabelName
labelLocation :: Maybe Span
labelMinimum :: CoverPercentage
labelAnnotation :: CoverCount
labelAnnotation :: forall a. Label a -> a
labelMinimum :: forall a. Label a -> CoverPercentage
labelLocation :: forall a. Label a -> Maybe Span
labelName :: forall a. Label a -> LabelName
..} <- (Label CoverCount -> Maybe Span)
-> [Label CoverCount] -> [Label CoverCount]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Label CoverCount -> Maybe Span
forall a. Label a -> Maybe Span
Hedgehog.labelLocation ([Label CoverCount] -> [Label CoverCount])
-> [Label CoverCount] -> [Label CoverCount]
forall a b. (a -> b) -> a -> b
$ Map k (Label CoverCount) -> [Label CoverCount]
forall k a. Map k a -> [a]
Map.elems Map k (Label CoverCount)
coverage
            , let
                Hedgehog.LabelName [Char]
name = LabelName
labelName
                Hedgehog.CoverCount Int
count = CoverCount
labelAnnotation
                percent :: Int
percent = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ p -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
testCount Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
100 :: Double)
                percentStr :: [Char]
percentStr = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
percent [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"%"
                percentBar :: [Char]
percentBar = Int -> [Char]
renderPercentBar Int
percent
            ]
          (Int
maxNameLen, Int
maxPercentLen) =
            (([Char], [Char], [Char]) -> (Int, Int) -> (Int, Int))
-> (Int, Int) -> [([Char], [Char], [Char])] -> (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
              ( \([Char]
name, [Char]
percent, [Char]
_) (Int
nameAcc, Int
percentAcc) ->
                  (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name) Int
nameAcc, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
percent) Int
percentAcc)
              )
              (Int
0, Int
0)
              [([Char], [Char], [Char])]
columns
       in [ Int -> [Char] -> [Char]
rjust Int
maxNameLen [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char] -> [Char]
rjust Int
maxPercentLen [Char]
percentStr [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
percentBar
          | ([Char]
name, [Char]
percentStr, [Char]
percentBar) <- [([Char], [Char], [Char])]
columns
          ]
    rjust :: Int -> [Char] -> [Char]
rjust Int
n [Char]
s = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
' ' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s
    renderPercentBar :: Int -> [Char]
renderPercentBar Int
percent =
      -- render percentage bar 20 characters wide
      let (Int
n, Int
r) = Int
percent Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
5
       in [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
n Char
'█'
            , case Int
r of
                Int
0 -> [Char]
""
                Int
1 -> [Char]
"▏"
                Int
2 -> [Char]
"▍"
                Int
3 -> [Char]
"▌"
                Int
4 -> [Char]
"▊"
                Int
_ -> [Char]
"" -- unreachable
            , Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
1)) Char
'·'
            ]
    toCallStack :: Maybe Span -> CallStack
toCallStack Maybe Span
mSpan =
      [([Char], SrcLoc)] -> CallStack
GHC.fromCallSiteList ([([Char], SrcLoc)] -> CallStack)
-> [([Char], SrcLoc)] -> CallStack
forall a b. (a -> b) -> a -> b
$
        case Maybe Span
mSpan of
          Maybe Span
Nothing -> []
          Just Hedgehog.Span{[Char]
ColumnNo
LineNo
spanEndColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanStartLine :: Span -> LineNo
spanFile :: Span -> [Char]
spanFile :: [Char]
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
..} ->
            let loc :: SrcLoc
loc =
                  GHC.SrcLoc
                    { srcLocPackage :: [Char]
srcLocPackage = [Char]
""
                    , srcLocModule :: [Char]
srcLocModule = [Char]
""
                    , srcLocFile :: [Char]
srcLocFile = [Char]
spanFile
                    , srcLocStartLine :: Int
srcLocStartLine = LineNo -> Int
Hedgehog.unLineNo LineNo
spanStartLine
                    , srcLocStartCol :: Int
srcLocStartCol = ColumnNo -> Int
Hedgehog.unColumnNo ColumnNo
spanStartColumn
                    , srcLocEndLine :: Int
srcLocEndLine = LineNo -> Int
Hedgehog.unLineNo LineNo
spanEndLine
                    , srcLocEndCol :: Int
srcLocEndCol = ColumnNo -> Int
Hedgehog.unColumnNo ColumnNo
spanEndColumn
                    }
             in [([Char]
"<unknown>", SrcLoc
loc)]

loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig])
loadPropFlags :: IO (Seed, [PropertyConfig])
loadPropFlags = do
  PropSeedFlag mSeed <- IO PropSeedFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
  seed <- maybe Hedgehog.Seed.random pure mSeed

  PropLimitFlag mLimit <- getFlag

  let extraConfig =
        [ Int -> PropertyConfig
SetTestLimit (Int -> PropertyConfig) -> Maybe Int -> Maybe PropertyConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
mLimit
        ]
  pure (seed, catMaybes extraConfig)

{----- Test -----}

forAll :: (GHC.HasCallStack, Show a) => Hedgehog.Gen a -> PropertyM a
forAll :: forall a. (HasCallStack, Show a) => Gen a -> PropertyM a
forAll Gen a
gen = (HasCallStack => PropertyM a) -> PropertyM a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM a) -> PropertyM a)
-> (HasCallStack => PropertyM a) -> PropertyM a
forall a b. (a -> b) -> a -> b
$ PropertyT IO a -> PropertyM a
forall a. PropertyT IO a -> PropertyM a
propM (Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
Hedgehog.forAll Gen a
gen)

discard :: PropertyM a
discard :: forall a. PropertyM a
discard = PropertyT IO a -> PropertyM a
forall a. PropertyT IO a -> PropertyM a
propM PropertyT IO a
forall (m :: * -> *) a. Monad m => PropertyT m a
Hedgehog.discard

{----- Configuring properties -----}

setDiscardLimit :: Int -> Property
setDiscardLimit :: Int -> PropertyM ()
setDiscardLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
DiscardLimit

setShrinkLimit :: Int -> Property
setShrinkLimit :: Int -> PropertyM ()
setShrinkLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
ShrinkLimit

setShrinkRetries :: Int -> Property
setShrinkRetries :: Int -> PropertyM ()
setShrinkRetries = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
ShrinkRetries

setConfidence :: Int -> Property
setConfidence :: Int -> PropertyM ()
setConfidence = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
SetConfidence

setVerifiedTermination :: Property
setVerifiedTermination :: PropertyM ()
setVerifiedTermination = PropertyConfig -> PropertyM ()
propConfig PropertyConfig
SetVerifiedTermination

setTestLimit :: Int -> Property
setTestLimit :: Int -> PropertyM ()
setTestLimit = PropertyConfig -> PropertyM ()
propConfig (PropertyConfig -> PropertyM ())
-> (Int -> PropertyConfig) -> Int -> PropertyM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PropertyConfig
SetTestLimit

{----- Coverage -----}

-- | Record the propotion of tests which satisfy a given condition
--
-- @
-- xs <- forAll $ Gen.list (Range.linear 0 100) $ Gen.int (Range.linear 0 100)
-- for_ xs $ \x -> do
--   classify "newborns" $ x == 0
--   classify "children" $ x > 0 && x < 13
--   classify "teens" $ x > 12 && x < 20
-- @
classify :: (GHC.HasCallStack) => String -> Bool -> Property
classify :: HasCallStack => [Char] -> Bool -> PropertyM ()
classify [Char]
l Bool
cond = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ LabelName -> Bool -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> Bool -> m ()
Hedgehog.classify ([Char] -> LabelName
Hedgehog.LabelName [Char]
l) Bool
cond

-- | Require a certain percentage of the tests to be covered by the classifier.
--
-- In the following example, if the condition does not have at least 30%
-- coverage, the test will fail.
--
-- @
-- match <- forAll Gen.bool
-- cover 30 "true" $ match
-- cover 30 "false" $ not match
-- @
cover :: (GHC.HasCallStack) => Double -> String -> Bool -> Property
cover :: HasCallStack => Double -> [Char] -> Bool -> PropertyM ()
cover Double
p [Char]
l Bool
cond = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ CoverPercentage -> LabelName -> Bool -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
CoverPercentage -> LabelName -> Bool -> m ()
Hedgehog.cover (Double -> CoverPercentage
Hedgehog.CoverPercentage Double
p) ([Char] -> LabelName
Hedgehog.LabelName [Char]
l) Bool
cond

-- | Add a label for each test run. It produces a table showing the percentage
-- of test runs that produced each label.
label :: (GHC.HasCallStack) => String -> Property
label :: HasCallStack => [Char] -> PropertyM ()
label [Char]
l = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ LabelName -> PropertyT IO ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> m ()
Hedgehog.label ([Char] -> LabelName
Hedgehog.LabelName [Char]
l)

-- | Like 'label', but uses 'Show' to render its argument for display.
collect :: (Show a, GHC.HasCallStack) => a -> Property
collect :: forall a. (Show a, HasCallStack) => a -> PropertyM ()
collect a
a = (HasCallStack => PropertyM ()) -> PropertyM ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM ()) -> PropertyM ())
-> (HasCallStack => PropertyM ()) -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ PropertyT IO () -> PropertyM ()
forall a. PropertyT IO a -> PropertyM a
propM (PropertyT IO () -> PropertyM ())
-> PropertyT IO () -> PropertyM ()
forall a b. (a -> b) -> a -> b
$ a -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
Hedgehog.collect a
a

{----- CLI flags -----}

newtype PropSeedFlag = PropSeedFlag (Maybe Hedgehog.Seed)

instance IsFlag PropSeedFlag where
  flagName :: [Char]
flagName = [Char]
"seed"
  flagMetaVar :: [Char]
flagMetaVar = [Char]
"SEED"
  flagHelp :: [Char]
flagHelp = [Char]
"The seed to use for property tests"
  flagSpec :: FlagSpec PropSeedFlag
flagSpec =
    OptionalFlag
      { flagDefault :: PropSeedFlag
flagDefault = Maybe Seed -> PropSeedFlag
PropSeedFlag Maybe Seed
forall a. Maybe a
Nothing
      , flagParse :: [Char] -> Either [Char] PropSeedFlag
flagParse = [Char] -> Either [Char] PropSeedFlag
parse
      }
    where
      parse :: [Char] -> Either [Char] PropSeedFlag
parse [Char]
s = Either [Char] PropSeedFlag
-> (PropSeedFlag -> Either [Char] PropSeedFlag)
-> Maybe PropSeedFlag
-> Either [Char] PropSeedFlag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Either [Char] PropSeedFlag
forall a b. a -> Either a b
Left ([Char] -> Either [Char] PropSeedFlag)
-> [Char] -> Either [Char] PropSeedFlag
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid seed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s) PropSeedFlag -> Either [Char] PropSeedFlag
forall a b. b -> Either a b
Right (Maybe PropSeedFlag -> Either [Char] PropSeedFlag)
-> Maybe PropSeedFlag -> Either [Char] PropSeedFlag
forall a b. (a -> b) -> a -> b
$ do
        (valS, ':' : gammaS) <- ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Char], [Char]) -> Maybe ([Char], [Char]))
-> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') [Char]
s
        val <- readMaybe valS
        gamma <- readMaybe gammaS
        pure . PropSeedFlag . Just $ Hedgehog.Seed val gamma

newtype PropLimitFlag = PropLimitFlag (Maybe Int)

instance IsFlag PropLimitFlag where
  flagName :: [Char]
flagName = [Char]
"prop-test-limit"
  flagMetaVar :: [Char]
flagMetaVar = [Char]
"N"
  flagHelp :: [Char]
flagHelp = [Char]
"The number of tests to run per property test"
  flagSpec :: FlagSpec PropLimitFlag
flagSpec =
    OptionalFlag
      { flagDefault :: PropLimitFlag
flagDefault = Maybe Int -> PropLimitFlag
PropLimitFlag Maybe Int
forall a. Maybe a
Nothing
      , flagParse :: [Char] -> Either [Char] PropLimitFlag
flagParse = (Int -> PropLimitFlag)
-> Either [Char] Int -> Either [Char] PropLimitFlag
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Int -> PropLimitFlag
PropLimitFlag (Maybe Int -> PropLimitFlag)
-> (Int -> Maybe Int) -> Int -> PropLimitFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int
forall a. a -> Maybe a
Just) (Either [Char] Int -> Either [Char] PropLimitFlag)
-> ([Char] -> Either [Char] Int)
-> [Char]
-> Either [Char] PropLimitFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] Int
forall a. Read a => [Char] -> Either [Char] a
readEither
      }