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

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

  -- * Test
  forAll,
  discard,

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

  -- * 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.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 (..), Testable (..))

-- | A property to run, with optional configuration settings specified up front.
--
-- Settings should be specified before any 'forAll' or IO 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 ()
runTestable = PropertyM () -> IO ()
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 ()
runProperty :: PropertyM () -> IO ()
runProperty = \case
  PropertyPure [PropertyConfig]
cfg () -> PropertyM () -> IO ()
runProperty (PropertyM () -> IO ()) -> PropertyM () -> IO ()
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

    case Hedgehog.reportStatus report of
      Result
Hedgehog.OK ->
        -- TODO: show details
        -- https://github.com/brandonchinn178/skeletest/issues/19
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      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 ()) -> IO ()
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 ()
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 Hedgehog.Report{reportSeed :: forall a. Report a -> Seed
reportSeed = Hedgehog.Seed Word64
value Word64
gamma} = 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
    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

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