{-# 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 :: 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
lawContextReduced :: String
lawContextTcProp :: String
lawContextTcName :: String
lawContextLawBody :: String
lawContextLawName :: String
lawContextReduced :: LawContext -> String
lawContextTcProp :: LawContext -> String
lawContextTcName :: LawContext -> String
lawContextLawBody :: LawContext -> String
lawContextLawName :: LawContext -> 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 (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 :: Gen a -> [Gen a -> Laws] -> IO Bool
lawsCheckOne Gen a
g = (All -> Bool) -> IO All -> IO Bool
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
b)

lawsCheckOneInternal :: Gen a -> [Gen a -> Laws] -> IO All
lawsCheckOneInternal :: 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Status
boolToStatus Bool
b)
    String -> IO ()
putStrLn String
""
    Status -> IO Status
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> All -> IO All
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 :: (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 (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 (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 :: Region -> Property -> m (Report Result)
checkRegion Region
region Property
prop = IO (Report Result) -> m (Report Result)
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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Report Result
result

check :: MonadIO m
  => Property
  -> m Bool
check :: Property -> m Bool
check Property
prop = IO Bool -> m Bool
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 { 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