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

    module Hedgehog.Classes.Common.Laws
      ( Laws(..)
      , LawContext(..)

      , lawsCheck
      , lawsCheckOne
      , lawsCheckMany

      , contextualise
      , reduced
      , lawWhere
      , congruency
      , implies

      , congruent
      , implication
      , newline
      , tab
      , tab2
      ) where

    import Control.Monad.IO.Class (MonadIO(liftIO))
    import Data.Char (isSpace)
    import Data.Monoid (All(..), Ap(..))
    import Hedgehog (Gen)
    import Hedgehog.Classes.Common.Property (Context(..))
    import Hedgehog.Internal.Config (UseColor(..))
    import Hedgehog.Internal.Property (Property(..))
    import Hedgehog.Internal.Region (Region)
    import Hedgehog.Internal.Report (Report, Result(..), Progress(..), renderProgress, reportStatus)
    import Hedgehog.Internal.Runner (checkReport)
    import System.Exit (exitFailure)
    import qualified Hedgehog.Classes.Common.PP as PP
    import qualified Hedgehog.Internal.Region as Region
    import qualified Hedgehog.Internal.Seed as Seed
    import qualified System.IO.Silently as S

    congruent :: String
    congruent :: String
    congruent = String
    " ≡ "

    implication :: String
    implication :: String
    implication = String
    " ==> "

    congruency :: String -> String -> String
    congruency :: String -> String -> String
    congruency String
    x String
    y = String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    congruent String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    y

    implies :: String -> String -> String
    implies :: String -> String -> String
    implies String
    x String
    y = String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    implication String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    y

    newline, tab, tab2 :: String
    newline :: String
    newline = String
    "\n"
    tab :: String
    tab = String
    "    "
    tab2 :: String
    tab2 = String
    "  "

    -- | For footnotes
    dagger :: String
    dagger :: String
    dagger = String
    "†"

    lawWhere :: [String] -> String
    lawWhere :: [String] -> String
    lawWhere [] = []
    lawWhere (String
    l:[String]
    ls) = String
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    newline String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tab2 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    lawWhere [String]
    ls

    -- | A 'Laws' is the name of the typeclass and the set of named properties associated with that typeclass.
    data Laws = Laws
      { Laws -> String
    lawsTypeClass :: String
      , Laws -> [(String, Property)]
    lawsProperties :: [(String, Property)]
      }

    -- | The context surrounding the property test of a law. Use 'contextualise' to turn this into a 'Context'.
    data LawContext = LawContext
      { LawContext -> String
    lawContextLawName :: String -- ^ law name
      , LawContext -> String
    lawContextLawBody :: String -- ^ law body
      , LawContext -> String
    lawContextTcName  :: String -- ^ typeclass name
      , LawContext -> String
    lawContextTcProp  :: String -- ^ how to show the specific property test
      , LawContext -> String
    lawContextReduced :: String -- ^ reduced equation, eg "LHS = RHS" where neither LHS nor RHS are reducible
      }

    reduced :: Show a => a -> a -> String
    reduced :: forall a. Show a => a -> a -> String
    reduced a
    lhs a
    rhs = a -> String
    forall a. Show a => a -> String
    show a
    lhs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    congruent String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    rhs

    -- | Turn a 'LawContext' into a 'Context'.
    contextualise :: LawContext -> Context
    contextualise :: LawContext -> Context
    contextualise LawContext{String
    lawContextLawName :: LawContext -> String
    lawContextLawBody :: LawContext -> String
    lawContextTcName :: LawContext -> String
    lawContextTcProp :: LawContext -> String
    lawContextReduced :: LawContext -> String
    lawContextLawName :: String
    lawContextLawBody :: String
    lawContextTcName :: String
    lawContextTcProp :: String
    lawContextReduced :: String
    ..} = String -> Context
    Context (String -> Context) -> String -> Context
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines
      [ String
    "When testing the " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextLawName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " law(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    dagger String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "), for the " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextTcName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " typeclass, the following test failed: "
      , String
    newline String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextTcProp
      , String
    newline String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "The reduced test is: "
      , String
    tab2 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextReduced
      , String
    newline String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "The law in question: "
      , String
    tab2 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    dagger String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextLawName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " Law: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lawContextLawBody
      ]

    -- | A convenience function for testing the properties of a typeclass.
    --   For example, in GHCi:
    --
    -- >>> genOrdering :: Gen Ordering; genOrdering = frequency [(1,pure EQ),(1,pure LT),(1,pure GT)]
    -- >>> lawsCheck (monoidLaws genOrdering)
    -- Monoid: Left Identity    ✓ <interactive> passed 100 tests.
    -- Monoid: Right Identity    ✓ <interactive> passed 100 tests.
    -- Monoid: Associativity    ✓ <interactive> passed 100 tests.
    -- Monoid: Concatenation    ✓ <interactive> passed 100 tests.
    -- True
    lawsCheck ::
         Laws -- ^ The 'Laws' you would like to check.
      -> IO Bool -- ^ 'True' if your tests pass, 'False' otherwise.
    lawsCheck :: Laws -> IO Bool
    lawsCheck = (All -> Bool) -> IO All -> IO Bool
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap All -> Bool
    getAll (IO All -> IO Bool) -> (Laws -> IO All) -> Laws -> IO Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Laws -> IO All
    lawsCheckInternal

    -- | A convenience function for testing many typeclass instances of
    --   a single type.
    --
    -- >>> lawsCheckOne (word8 constantBounded) [jsonLaws, showReadLaws]
    -- ToJSON/FromJSON: Partial Isomorphism    ✓ <interactive> passed 100 tests.
    -- ToJSON/FromJSON: Encoding equals value    ✓ <interactive> passed 100 tests.
    -- Show/Read: Partial Isomorphism: show/read    ✓ <interactive> passed 100 tests.
    -- Show/Read: Partial Isomorphism: show/read with initial space    ✓ <interactive> passed 100 tests.
    -- Show/Read: Partial Isomorphism: showsPrec/readsPrec    ✓ <interactive> passed 100 tests.
    -- Show/Read: Partial Isomorphism: showList/readList    ✓ <interactive> passed 100 tests.
    -- Show/Read: Partial Isomorphism: showListWith shows/readListDefault    ✓ <interactive> passed 100 tests.
    -- True
    lawsCheckOne ::
         Gen a -- ^ The generator for your type.
      -> [Gen a -> Laws] -- ^ Functions that take a generator and output 'Laws'.
      -> IO Bool -- ^ 'True' if your tests pass. 'False' otherwise.
    lawsCheckOne :: forall a. Gen a -> [Gen a -> Laws] -> IO Bool
    lawsCheckOne Gen a
    g = (All -> Bool) -> IO All -> IO Bool
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap All -> Bool
    getAll (IO All -> IO Bool)
    -> ([Gen a -> Laws] -> IO All) -> [Gen a -> Laws] -> IO Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Gen a -> [Gen a -> Laws] -> IO All
    forall a. Gen a -> [Gen a -> Laws] -> IO All
    lawsCheckOneInternal Gen a
    g

    -- | A convenience function for checking many typeclass instances of
    --   multiple types.
    --
    -- @
    -- import Control.Applicative (liftA2)
    --
    -- import Data.Map (Map)
    -- import Data.Set (Set)
    --
    -- import qualified Data.List as List
    -- import qualified Data.Set as Set
    -- import qualified Data.Map as Map
    --
    -- import qualified Hedgehog.Gen as Gen
    -- import qualified Hedgehog.Range as Range
    --
    -- import Hedgehog (Gen)
    -- import Hedgehog.Classes
    --
    -- -- Generate a small @Set Int@
    -- genSet :: Gen (Set Int)
    -- genSet = Set.fromList \<$\> (Gen.list (Range.linear 2 10) (Gen.int Range.constantBounded))
    --
    -- -- Generate a small @Map String Int@
    -- genMap :: Gen (Map String Int)
    -- genMap = Map.fromList \<$\> (liftA2 List.zip genStrings genInts)
    --   where
    --     rng = Range.linear 2 6
    --     genStrings = Gen.list rng (Gen.string rng Gen.lower)
    --     genInts = Gen.list rng (Gen.int Range.constantBounded)
    --
    -- commonLaws :: (Eq a, Monoid a, Show a) => Gen a -> [Laws]
    -- commonLaws p = [eqLaws p, monoidLaws p]
    --
    -- tests :: [(String, [Laws])]
    -- tests =
    --   [ ("Set Int", commonLaws genSet)
    --   , ("Map String Int", commonLaws genMap)
    --   ]
    -- @
    --
    -- Now, in GHCi:
    --
    -- >>> lawsCheckMany tests
    --
    -- @
    -- Testing properties for common typeclasses...
    --
    -- -------------
    -- -- Set Int --
    -- -------------
    --
    -- Eq: Transitive   ✓ <interactive> passed 100 tests.
    -- Eq: Symmetric   ✓ <interactive> passed 100 tests.
    -- Eq: Reflexive   ✓ <interactive> passed 100 tests.
    -- Eq: Negation   ✓ <interactive> passed 100 tests.
    -- Monoid: Left Identity   ✓ <interactive> passed 100 tests.
    -- Monoid: Right Identity   ✓ <interactive> passed 100 tests.
    -- Monoid: Associativity   ✓ <interactive> passed 100 tests.
    -- Monoid: Concatenation   ✓ <interactive> passed 100 tests.
    --
    -- --------------------
    -- -- Map String Int --
    -- --------------------
    --
    -- Eq: Transitive   ✓ <interactive> passed 100 tests.
    -- Eq: Symmetric   ✓ <interactive> passed 100 tests.
    -- Eq: Reflexive   ✓ <interactive> passed 100 tests.
    -- Eq: Negation   ✓ <interactive> passed 100 tests.
    -- Monoid: Left Identity   ✓ <interactive> passed 100 tests.
    -- Monoid: Right Identity   ✓ <interactive> passed 100 tests.
    -- Monoid: Associativity   ✓ <interactive> passed 100 tests.
    -- Monoid: Concatenation   ✓ <interactive> passed 100 tests.
    --
    -- All tests succeeded
    -- True
    -- @
    lawsCheckMany ::
         [(String, [Laws])] -- ^ Pairs of type names and their associated laws to test.
      -> IO Bool -- ^ 'True' if your tests pass. 'False' otherwise.
    lawsCheckMany :: [(String, [Laws])] -> IO Bool
    lawsCheckMany = (All -> Bool) -> IO All -> IO Bool
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap All -> Bool
    getAll (IO All -> IO Bool)
    -> ([(String, [Laws])] -> IO All) -> [(String, [Laws])] -> IO Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(String, [Laws])] -> IO All
    lawsCheckManyInternal

    lawsCheckInternal :: Laws -> IO All
    lawsCheckInternal :: Laws -> IO All
    lawsCheckInternal (Laws String
    className [(String, Property)]
    properties) =
      (((String, Property) -> IO All) -> [(String, Property)] -> IO All)
    -> [(String, Property)] -> ((String, Property) -> IO All) -> IO All
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((String, Property) -> IO All) -> [(String, Property)] -> IO All
    forall (t :: * -> *) m (f :: * -> *) a.
    (Foldable t, Monoid m, Applicative f) =>
    (a -> f m) -> t a -> f m
    foldMapA [(String, Property)]
    properties (((String, Property) -> IO All) -> IO All)
    -> ((String, Property) -> IO All) -> IO All
    forall a b. (a -> b) -> a -> b
    $ \(String
    name,Property
    p) -> do
        String -> IO ()
    putStr (String
    className String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " ")
        (String
    out,Bool
    b) <- IO Bool -> IO (String, Bool)
    forall a. IO a -> IO (String, a)
    S.capture (IO Bool -> IO (String, Bool)) -> IO Bool -> IO (String, Bool)
    forall a b. (a -> b) -> a -> b
    $ Property -> IO Bool
    forall (m :: * -> *). MonadIO m => Property -> m Bool
    check Property
    p
        if Bool
    b
          then String -> IO ()
    putStr String
    "   ✓ <interactive> passed 100 tests.\n"
          else String -> IO ()
    putStr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String -> String
    removeBadOutput String
    out) String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
        All -> IO All
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> All
    All Bool
    b)

    lawsCheckOneInternal :: Gen a -> [Gen a -> Laws] -> IO All
    lawsCheckOneInternal :: forall a. Gen a -> [Gen a -> Laws] -> IO All
    lawsCheckOneInternal Gen a
    p [Gen a -> Laws]
    ls = ((Gen a -> Laws) -> IO All) -> [Gen a -> Laws] -> IO All
    forall m a. Monoid m => (a -> m) -> [a] -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap (Laws -> IO All
    lawsCheckInternal (Laws -> IO All)
    -> ((Gen a -> Laws) -> Laws) -> (Gen a -> Laws) -> IO All
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Gen a -> Laws) -> Gen a -> Laws
    forall a b. (a -> b) -> a -> b
    $ Gen a
    p)) [Gen a -> Laws]
    ls

    lawsCheckManyInternal :: [(String, [Laws])] -> IO All
    lawsCheckManyInternal :: [(String, [Laws])] -> IO All
    lawsCheckManyInternal [(String, [Laws])]
    xs = do
      String -> IO ()
    putStrLn String
    ""
      String -> IO ()
    putStrLn String
    "Testing properties for common typeclasses..."
      String -> IO ()
    putStrLn String
    ""
      Status
    r <- (((String, [Laws]) -> IO Status)
     -> [(String, [Laws])] -> IO Status)
    -> [(String, [Laws])]
    -> ((String, [Laws]) -> IO Status)
    -> IO Status
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((String, [Laws]) -> IO Status) -> [(String, [Laws])] -> IO Status
    forall (t :: * -> *) m (f :: * -> *) a.
    (Foldable t, Monoid m, Applicative f) =>
    (a -> f m) -> t a -> f m
    foldMapA [(String, [Laws])]
    xs (((String, [Laws]) -> IO Status) -> IO Status)
    -> ((String, [Laws]) -> IO Status) -> IO Status
    forall a b. (a -> b) -> a -> b
    $ \(String
    typeName, [Laws]
    laws) -> do
        String -> IO ()
    putStrLn (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> String
    prettyHeader String
    typeName
        Status
    r <- ((Laws -> IO Status) -> [Laws] -> IO Status)
    -> [Laws] -> (Laws -> IO Status) -> IO Status
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Laws -> IO Status) -> [Laws] -> IO Status
    forall (t :: * -> *) m (f :: * -> *) a.
    (Foldable t, Monoid m, Applicative f) =>
    (a -> f m) -> t a -> f m
    foldMapA [Laws]
    laws ((Laws -> IO Status) -> IO Status)
    -> (Laws -> IO Status) -> IO Status
    forall a b. (a -> b) -> a -> b
    $ \(Laws String
    typeclassName [(String, Property)]
    properties) -> do
          (((String, Property) -> IO Status)
     -> [(String, Property)] -> IO Status)
    -> [(String, Property)]
    -> ((String, Property) -> IO Status)
    -> IO Status
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((String, Property) -> IO Status)
    -> [(String, Property)] -> IO Status
    forall (t :: * -> *) m (f :: * -> *) a.
    (Foldable t, Monoid m, Applicative f) =>
    (a -> f m) -> t a -> f m
    foldMapA [(String, Property)]
    properties (((String, Property) -> IO Status) -> IO Status)
    -> ((String, Property) -> IO Status) -> IO Status
    forall a b. (a -> b) -> a -> b
    $ \(String
    name,Property
    p) -> do
            String -> IO ()
    putStr (String
    typeclassName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name)
            (String
    out,Bool
    b) <- IO Bool -> IO (String, Bool)
    forall a. IO a -> IO (String, a)
    S.capture (IO Bool -> IO (String, Bool)) -> IO Bool -> IO (String, Bool)
    forall a b. (a -> b) -> a -> b
    $ Property -> IO Bool
    forall (m :: * -> *). MonadIO m => Property -> m Bool
    check Property
    p
            if Bool
    b
              then String -> IO ()
    putStr String
    "   ✓ <interactive> passed 100 tests.\n"
              else String -> IO ()
    putStr (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String -> String
    removeBadOutput String
    out) String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
            Status -> IO Status
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> Status
    boolToStatus Bool
    b)
        String -> IO ()
    putStrLn String
    ""
        Status -> IO Status
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Status
    r
      String -> IO ()
    putStrLn String
    ""
      case Status
    r of
        Status
    Good -> String -> IO ()
    putStrLn String
    "All tests succeeded" IO () -> IO All -> IO All
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> All -> IO All
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure All
    forall a. Monoid a => a
    mempty
        Status
    Bad  -> do
          String -> IO ()
    putStrLn String
    "One or more tests failed"
          IO All
    forall a. IO a
    exitFailure

    foldMapA :: (Foldable t, Monoid m, Applicative f) => (a -> f m) -> t a -> f m
    foldMapA :: forall (t :: * -> *) m (f :: * -> *) a.
    (Foldable t, Monoid m, Applicative f) =>
    (a -> f m) -> t a -> f m
    foldMapA a -> f m
    f = Ap f m -> f m
    forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
    getAp (Ap f m -> f m) -> (t a -> Ap f m) -> t a -> f m
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> Ap f m) -> t a -> Ap f m
    forall m a. Monoid m => (a -> m) -> t a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap (f m -> Ap f m
    forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
    Ap (f m -> Ap f m) -> (a -> f m) -> a -> Ap f m
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> f m
    f)

    prettyHeader :: String -> String
    prettyHeader :: String -> String
    prettyHeader String
    s = [String] -> String
    unlines [String
    topLine, String
    middleLine, String
    bottomLine]
      where
        line :: String
    line = Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    6) Char
    '-'
        topLine :: String
    topLine = String
    line
        bottomLine :: String
    bottomLine = String
    line
        middleLine :: String
    middleLine = String
    "-- " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " --"

    data Status = Bad | Good

    instance Semigroup Status where
      Status
    Good <> :: Status -> Status -> Status
    <> Status
    x = Status
    x
      Status
    Bad <> Status
    _ = Status
    Bad

    instance Monoid Status where
      mempty :: Status
    mempty = Status
    Good

    boolToStatus :: Bool -> Status
    boolToStatus :: Bool -> Status
    boolToStatus = \case { Bool
    False -> Status
    Bad; Bool
    True -> Status
    Good; }

    checkRegion :: MonadIO m
      => Region
      -> Property
      -> m (Report Result)
    checkRegion :: forall (m :: * -> *).
    MonadIO m =>
    Region -> Property -> m (Report Result)
    checkRegion Region
    region Property
    prop = IO (Report Result) -> m (Report Result)
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Report Result) -> m (Report Result))
    -> IO (Report Result) -> m (Report Result)
    forall a b. (a -> b) -> a -> b
    $ do
      Seed
    seed <- IO Seed -> IO Seed
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Seed
    forall (m :: * -> *). MonadIO m => m Seed
    Seed.random
      Report Result
    result <- 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 (Property -> PropertyConfig
    propertyConfig Property
    prop) Size
    0 Seed
    seed (Property -> PropertyT IO ()
    propertyTest Property
    prop) ((Report Progress -> IO ()) -> IO (Report Result))
    -> (Report Progress -> IO ()) -> IO (Report Result)
    forall a b. (a -> b) -> a -> b
    $ \Report Progress
    progress -> do
    #if MIN_VERSION_hedgehog(1,0,2)
        let u :: UseColor
    u = UseColor
    EnableColor
    #else
        let u = Just EnableColor
    #endif
        String
    ppprogress <- UseColor -> Maybe PropertyName -> Report Progress -> IO String
    forall (m :: * -> *).
    MonadIO m =>
    UseColor -> Maybe PropertyName -> Report Progress -> m String
    renderProgress UseColor
    u Maybe PropertyName
    forall a. Maybe a
    Nothing Report Progress
    progress
        case Report Progress -> Progress
    forall a. Report a -> a
    reportStatus Report Progress
    progress of
          Progress
    Running -> Region -> String -> IO ()
    forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
    Region.setRegion Region
    region String
    ppprogress
          Shrinking FailureReport
    _ -> Region -> String -> IO ()
    forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
    Region.openRegion Region
    region String
    ppprogress
      String
    ppresult <- Report Result -> IO String
    forall (m :: * -> *). MonadIO m => Report Result -> m String
    PP.renderResult Report Result
    result
      case Report Result -> Result
    forall a. Report a -> a
    reportStatus Report Result
    result of
        Failed FailureReport
    _ -> Region -> String -> IO ()
    forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
    Region.openRegion Region
    region String
    ppresult
        Result
    GaveUp -> Region -> String -> IO ()
    forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
    Region.openRegion Region
    region String
    ppresult
        Result
    OK -> Region -> String -> IO ()
    forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
    Region.setRegion Region
    region String
    ppresult
      Report Result -> IO (Report Result)
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Report Result
    result

    check :: MonadIO m
      => Property
      -> m Bool
    check :: forall (m :: * -> *). MonadIO m => Property -> m Bool
    check Property
    prop = IO Bool -> m Bool
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> m Bool)
    -> ((Region -> IO Bool) -> IO Bool)
    -> (Region -> IO Bool)
    -> m Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Region -> IO Bool) -> IO Bool
    forall (m :: * -> *) a.
    (MonadIO m, MonadMask m, LiftRegion m) =>
    (Region -> m a) -> m a
    Region.displayRegion ((Region -> IO Bool) -> m Bool) -> (Region -> IO Bool) -> m Bool
    forall a b. (a -> b) -> a -> b
    $ \Region
    region ->
      (Result -> Result -> Bool
    forall a. Eq a => a -> a -> Bool
    == Result
    OK) (Result -> Bool)
    -> (Report Result -> Result) -> Report Result -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Report Result -> Result
    forall a. Report a -> a
    reportStatus (Report Result -> Bool) -> IO (Report Result) -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Region -> Property -> IO (Report Result)
    forall (m :: * -> *).
    MonadIO m =>
    Region -> Property -> m (Report Result)
    checkRegion Region
    region Property
    prop

    -- HACK!
    -- BAD!
    -- ALERT!

    stripLeading :: String -> String
    stripLeading :: String -> String
    stripLeading = \case
      [] -> []
      s :: String
    s@(Char
    x:String
    xs) -> if Char -> Bool
    isSpace Char
    x
        then String -> String
    stripLeading String
    xs
        else String
    s

    -- | Like 'Data.Functor.Contravariant.Predicate', but its
    --   Semigroup/Monoid instances are disjunctive instead of
    --   conjunctive.
    newtype DPredicate a = DPredicate { forall a. DPredicate a -> a -> Bool
    getDPredicate :: a -> Bool }
    instance Semigroup (DPredicate a) where
      DPredicate a -> Bool
    p <> :: DPredicate a -> DPredicate a -> DPredicate a
    <> DPredicate a -> Bool
    q = (a -> Bool) -> DPredicate a
    forall a. (a -> Bool) -> DPredicate a
    DPredicate ((a -> Bool) -> DPredicate a) -> (a -> Bool) -> DPredicate a
    forall a b. (a -> b) -> a -> b
    $ \a
    a -> a -> Bool
    p a
    a Bool -> Bool -> Bool
    || a -> Bool
    q a
    a
    instance Monoid (DPredicate a) where
      mempty :: DPredicate a
    mempty = (a -> Bool) -> DPredicate a
    forall a. (a -> Bool) -> DPredicate a
    DPredicate ((a -> Bool) -> DPredicate a) -> (a -> Bool) -> DPredicate a
    forall a b. (a -> b) -> a -> b
    $ Bool -> a -> Bool
    forall a b. a -> b -> a
    const Bool
    False

    startsWithCorner :: DPredicate String
    startsWithCorner :: DPredicate String
    startsWithCorner = (String -> Bool) -> DPredicate String
    forall a. (a -> Bool) -> DPredicate a
    DPredicate ((String -> Bool) -> DPredicate String)
    -> (String -> Bool) -> DPredicate String
    forall a b. (a -> b) -> a -> b
    $ \case
      [] -> Bool
    False
      (Char
    x:String
    _) -> Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '┏'

    containsBar :: DPredicate String
    containsBar :: DPredicate String
    containsBar = (String -> Bool) -> DPredicate String
    forall a. (a -> Bool) -> DPredicate a
    DPredicate ((String -> Bool) -> DPredicate String)
    -> (String -> Bool) -> DPredicate String
    forall a b. (a -> b) -> a -> b
    $ \String
    s -> (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '┃') String
    s

    isBad :: String -> Bool
    isBad :: String -> Bool
    isBad = DPredicate String -> String -> Bool
    forall a. DPredicate a -> a -> Bool
    getDPredicate (DPredicate String -> String -> Bool)
    -> DPredicate String -> String -> Bool
    forall a b. (a -> b) -> a -> b
    $ [DPredicate String] -> DPredicate String
    forall a. Monoid a => [a] -> a
    mconcat
      [ DPredicate String
    startsWithCorner
      , DPredicate String
    containsBar
      ]

    removeBadOutput :: String -> String
    removeBadOutput :: String -> String
    removeBadOutput = [String] -> String
    unlines ([String] -> String) -> (String -> [String]) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> [String]
    go ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines where
      go :: [String] -> [String]
    go [] = []
      go (String
    x:[String]
    xs) = if String -> Bool
    isBad (String -> String
    stripLeading String
    x)
        then [String] -> [String]
    go [String]
    xs
        else String
    x String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String] -> [String]
    go [String]
    xs