{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module allows you to easily integrate the "Hedgehog" library with
-- "Test.Hspec" test-suites.
--
-- To get started, check out the 'hedgehog' function, which lets you embed
-- a 'PropertyT' directly.
--
-- @
-- spec :: 'Spec'
-- spec =
--   'describe' \"my great test\" '$' do
--     'it' \"generates stuff\" '$'
--       'hedgehog' '$' do
--         a <- 'forAll' generator
--         a '===' expected
-- @
--
-- Truth be told, the functionality is in the two orphan instances of
-- 'Example' for 'PropertyT'. You can directly use code in the @'PropertyT'
-- 'IO'@ type. However, because most "Hedgehog" functions are abstract in
-- 'MonadTest', you might get errors about ambiguous types. The 'hedgehog'
-- function fixes the type to @'PropertyT' 'IO' '()'@, which works out just
-- fine.
--
-- You can use all of @hspec@'s hooks with this, of course.
--
-- @
-- spec :: Spec
-- spec = 'before' ('pure' \"Hello!\") '$' do
--   'describe' \"with a string\" '$' do
--     'it' \"gets a string\" '$' \\ str ->
--       'hedgehog' '$' do
--         wrongLen <- 'forAll' $ 'Gen.integral' ('Range.linear' 0 3)
--         length str '/==' wrongLen
-- @
--
-- The function 'before' will make all the following spec items a function,
-- accepting that as a parameter. You should call 'hedgehog' after the
-- lambda.
--
-- If you are morally opposed to the pattern:
--
-- @
-- 'it' \"message\" $ 'hedgehog' $ do
--   True '===' False
-- @
--
-- Then you can alternatively force the type some other way. One option is
-- to use a no-op function, like this:
--
-- @
-- 'it' \"message\" $ do
--   'pure' () :: 'PropertyT' 'IO' ()
--   True '===' False
-- @
--
-- This style has the advantage that parameters via hooks are less
-- difficult to get right.
--
-- @
-- 'before' ('pure' \"Hello!\") $ do
--   'it' \"message\" $ \\str -> do
--     'pure' () :: 'PropertyT' 'IO' ()
--     wrongLen <- 'forAll' $ 'Gen.integral' ('Range.linear' 0 3)
--     'length' str '/==' wrongLen
-- @
--
-- You don't have to remember to put the 'hedgehog' call after the lambda.
module Test.Hspec.Hedgehog
    ( -- * The Main Function
      hedgehog
      -- * Hspec re-exports
      --
      -- | 'Test.Hspec.QuickCheck.modifyMaxSize' isn't re-exported, since
      -- hedgehog has nothing that corresponds to it.
    , modifyArgs
    , modifyMaxSuccess
    , modifyMaxDiscardRatio
    , modifyMaxShrinks
      -- * Hedgehog Re-exports
    , module Hedgehog
    ) where

import           Control.Monad.IO.Class     (liftIO)
import           Data.Char                  (isSpace)
import           Data.Coerce                (coerce)
import           Data.IORef                 (newIORef, readIORef, writeIORef)
import           GHC.Stack                  (withFrozenCallStack)
import           Hedgehog
import           Hedgehog.Internal.Config   (UseColor(..))
import           Hedgehog.Internal.Property (DiscardLimit (..), Property (..),
                                             PropertyConfig (..),
                                             ShrinkLimit (..),
                                             TerminationCriteria (..),
                                             TestCount (..), TestLimit (..))
import           Hedgehog.Internal.Report   hiding (renderResult)
import           Hedgehog.Internal.Runner   (checkReport)
import qualified Hedgehog.Internal.Seed     as Seed
import           Hedgehog.Internal.Source   (ColumnNo (..), LineNo (..),
                                             Span (..))
import           System.Random.SplitMix     (unseedSMGen)
import           Test.Hspec
import           Test.Hspec.Core.Spec       as Hspec
import           Test.Hspec.QuickCheck      (modifyArgs, modifyMaxDiscardRatio,
                                             modifyMaxShrinks, modifyMaxSuccess)
import           Test.QuickCheck.Random     (QCGen (..))
import           Test.QuickCheck.Test       (Args (..))

-- | Embed a "Hedgehog" @'PropertyT' 'IO' ()@ in an @hspec@ test.
--
-- @
-- spec :: 'Spec'
-- spec =
--   'describe' \"my great test\" '$' do
--     'it' \"generates stuff\" '$'
--       'hedgehog' '$' do
--         a <- 'forAll' generator
--         a '===' expected
-- @
--
-- This function is only used to fix the type of the @'PropertyT'@ monad
-- transformer. The functions in "Hedgehog" are typically abstract in
-- a 'MonadTest', and it's easy to get ambiguous type errors if you leave
-- this out.
--
-- @since 0.0.0.0
hedgehog :: HasCallStack => PropertyT IO () -> PropertyT IO ()
hedgehog :: HasCallStack => PropertyT IO () -> PropertyT IO ()
hedgehog = PropertyT IO () -> PropertyT IO ()
forall a. a -> a
id

-- |  Warning: Orphan instance! This instance is used to embed a "Hedgehog"
-- property seamlessly into the @hspec@ framework. See the other instance
-- of 'Example' for a function for more details.
--
-- @since 0.0.0.0
instance m ~ IO => Example (PropertyT m ()) where
    type Arg (PropertyT m ()) = ()
    evaluateExample :: PropertyT m ()
-> Params
-> (ActionWith (Arg (PropertyT m ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample PropertyT m ()
e = (() -> PropertyT m ())
-> Params
-> (ActionWith (Arg (() -> PropertyT m ())) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample (\() -> PropertyT m ()
e)

propertyWithoutCallStack :: PropertyT IO () -> Property
propertyWithoutCallStack :: PropertyT IO () -> Property
propertyWithoutCallStack = (HasCallStack => PropertyT IO () -> Property)
-> PropertyT IO () -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property

-- | Warning: orphan instance! This instance is used to embed a "Hedgehog"
-- property seamlessly into the @hspec@ framework.
--
-- The instance will pick things up from the "Test.Hspec.QuickCheck"
-- configuration. For example, if the program is supposed to use
-- a predetermined seed, then the same seed will be used for QuickCheck and
-- Hedgehog tests.
--
-- @since 0.0.0.0
instance (m ~ IO) => Example (a -> PropertyT m ()) where
    type Arg (a -> PropertyT m ()) = a

    evaluateExample :: (a -> PropertyT m ())
-> Params
-> (ActionWith (Arg (a -> PropertyT m ())) -> IO ())
-> ProgressCallback
-> IO Result
evaluateExample ((PropertyT IO () -> Property)
-> (a -> PropertyT IO ()) -> a -> Property
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PropertyT IO () -> Property
propertyWithoutCallStack -> a -> Property
aprop) Params
params ActionWith (Arg (a -> PropertyT m ())) -> IO ()
aroundAction ProgressCallback
progressCallback = do
        IORef Result
ref <- Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef (String -> ResultStatus -> Result
Result String
"" (Maybe Location -> Maybe String -> ResultStatus
Pending Maybe Location
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing))
        ActionWith (Arg (a -> PropertyT m ())) -> IO ()
aroundAction (ActionWith (Arg (a -> PropertyT m ())) -> IO ())
-> ActionWith (Arg (a -> PropertyT m ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Arg (a -> PropertyT m ())
a ->  do
            let size :: Size
size = Size
0
                prop :: Property
prop = a -> Property
aprop a
Arg (a -> PropertyT m ())
a
                propConfig :: PropertyConfig
propConfig = PropertyConfig -> PropertyConfig
useQuickCheckArgs (Property -> PropertyConfig
propertyConfig Property
prop)
                qcArgs :: Args
qcArgs = Params -> Args
paramsQuickCheckArgs Params
params

                maxTests :: Int
maxTests = Args -> Int
maxSuccess Args
qcArgs
                useQuickCheckArgs :: PropertyConfig -> PropertyConfig
useQuickCheckArgs PropertyConfig
pc =
                    PropertyConfig
pc
                    { propertyTerminationCriteria =
                        case propertyTerminationCriteria pc of
                            EarlyTermination Confidence
x (TestLimit Int
_)      ->
                                Confidence -> TestLimit -> TerminationCriteria
EarlyTermination Confidence
x (Int -> TestLimit
TestLimit Int
maxTests)
                            NoEarlyTermination Confidence
x (TestLimit Int
_)    ->
                                Confidence -> TestLimit -> TerminationCriteria
NoEarlyTermination Confidence
x (Int -> TestLimit
TestLimit Int
maxTests)
                            NoConfidenceTermination (TestLimit Int
_) ->
                                TestLimit -> TerminationCriteria
NoConfidenceTermination (Int -> TestLimit
TestLimit Int
maxTests)
                    , propertyDiscardLimit =
                        DiscardLimit $ maxDiscardRatio qcArgs * maxTests
                    , propertyShrinkLimit =
                        ShrinkLimit $ maxShrinks qcArgs
                    }
                testCount :: Report a -> Int
testCount Report a
report =
                    case Report a -> TestCount
forall a. Report a -> TestCount
reportTests Report a
report of
                        TestCount Int
n -> Int
n
                cb :: Report Progress -> IO ()
cb Report Progress
progress = do
                    case Report Progress -> Progress
forall a. Report a -> a
reportStatus Report Progress
progress of
                        Progress
Running ->
                            ProgressCallback
progressCallback (Report Progress -> Int
forall {a}. Report a -> Int
testCount Report Progress
progress, Int
maxTests)
                        Shrinking FailureReport
_ ->
                            ProgressCallback
progressCallback (Report Progress -> Int
forall {a}. Report a -> Int
testCount Report Progress
progress, Int
maxTests)

            Seed
seed <- IO Seed -> IO Seed
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Seed -> IO Seed) -> IO Seed -> IO Seed
forall a b. (a -> b) -> a -> b
$ case Args -> Maybe (QCGen, Int)
replay (Params -> Args
paramsQuickCheckArgs Params
params) of
               Maybe (QCGen, Int)
Nothing       -> IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
               Just (QCGen
rng, Int
_) -> Seed -> IO Seed
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Word64 -> Word64 -> Seed) -> (Word64, Word64) -> Seed
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> Seed
Seed (SMGen -> (Word64, Word64)
unseedSMGen (QCGen -> SMGen
forall a b. Coercible a b => a -> b
coerce QCGen
rng)))
            Report Result
hedgeResult <- PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
checkReport PropertyConfig
propConfig Size
size Seed
seed (Property -> PropertyT IO ()
propertyTest Property
prop) Report Progress -> IO ()
cb

            let
              config :: Config
config = Config
defaultConfig {
                  configContext = Context 3
                , configPrintFailedAtLocation = False
                , configPrintReproduceMessage = False
                , configPrintPrefixIcons = DisablePrefixIcons
                }
              renderResult :: UseColor -> IO String
renderResult UseColor
color = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
unindent ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config
-> UseColor -> Maybe PropertyName -> Report Result -> IO String
forall (m :: * -> *).
MonadIO m =>
Config
-> UseColor -> Maybe PropertyName -> Report Result -> m String
renderResultWith Config
config UseColor
color (PropertyName -> Maybe PropertyName
forall a. a -> Maybe a
Just PropertyName
"") Report Result
hedgeResult

            case Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
hedgeResult of
                Failed FailureReport{String
[String]
[FailedAnnotation]
Maybe Span
Maybe (Coverage CoverCount)
Maybe Diff
ShrinkPath
ShrinkCount
failureShrinks :: ShrinkCount
failureShrinkPath :: ShrinkPath
failureCoverage :: Maybe (Coverage CoverCount)
failureAnnotations :: [FailedAnnotation]
failureLocation :: Maybe Span
failureMessage :: String
failureDiff :: Maybe Diff
failureFootnotes :: [String]
failureShrinks :: FailureReport -> ShrinkCount
failureShrinkPath :: FailureReport -> ShrinkPath
failureCoverage :: FailureReport -> Maybe (Coverage CoverCount)
failureAnnotations :: FailureReport -> [FailedAnnotation]
failureLocation :: FailureReport -> Maybe Span
failureMessage :: FailureReport -> String
failureDiff :: FailureReport -> Maybe Diff
failureFootnotes :: FailureReport -> [String]
..} -> do
                    String
ppresult <- UseColor -> IO String
renderResult UseColor
EnableColor
                    let
                        fromSpan :: Span -> Location
fromSpan Span{String
ColumnNo
LineNo
spanFile :: String
spanStartLine :: LineNo
spanStartColumn :: ColumnNo
spanEndLine :: LineNo
spanEndColumn :: ColumnNo
spanFile :: Span -> String
spanStartLine :: Span -> LineNo
spanStartColumn :: Span -> ColumnNo
spanEndLine :: Span -> LineNo
spanEndColumn :: Span -> ColumnNo
..} =
                            Location
                                { locationFile :: String
locationFile = String
spanFile
                                , locationLine :: Int
locationLine = LineNo -> Int
forall a b. Coercible a b => a -> b
coerce LineNo
spanStartLine
                                , locationColumn :: Int
locationColumn = ColumnNo -> Int
forall a b. Coercible a b => a -> b
coerce ColumnNo
spanStartColumn
                                }
                    IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
"" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Hspec.Failure (Span -> Location
fromSpan (Span -> Location) -> Maybe Span -> Maybe Location
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
failureLocation) (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
forall a b. (a -> b) -> a -> b
$ String -> FailureReason
ColorizedReason String
ppresult
                Result
GaveUp -> do
                    String
ppresult <- UseColor -> IO String
renderResult UseColor
DisableColor
                    IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
"" (ResultStatus -> Result) -> ResultStatus -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (String -> FailureReason
Reason String
ppresult)
                Result
OK -> do
                    String
ppresult <- UseColor -> IO String
renderResult UseColor
DisableColor
                    IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
ref (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
ppresult ResultStatus
Success
        IORef Result -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
ref

dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd :: forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd a -> Bool
p = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile a -> Bool
p ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

unindent :: [String] -> [String]
unindent :: [String] -> [String]
unindent [String]
xs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
indentation) [String]
xs
  where
    indentation :: Int
indentation = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) [String]
xs