{-# 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 forall a. [a] -> [a] -> [a]
++ String
congruent forall a. [a] -> [a] -> [a]
++ String
y
implies :: String -> String -> String
implies :: String -> String -> String
implies String
x String
y = String
x forall a. [a] -> [a] -> [a]
++ String
implication forall a. [a] -> [a] -> [a]
++ String
y
newline, tab, tab2 :: String
newline :: String
newline = String
"\n"
tab :: String
tab = String
" "
tab2 :: String
tab2 = String
" "
dagger :: String
dagger :: String
dagger = String
"†"
lawWhere :: [String] -> String
lawWhere :: [String] -> String
lawWhere [] = []
lawWhere (String
l:[String]
ls) = String
l forall a. [a] -> [a] -> [a]
++ String
newline forall a. [a] -> [a] -> [a]
++ String
tab2 forall a. [a] -> [a] -> [a]
++ [String] -> String
lawWhere [String]
ls
data Laws = Laws
{ Laws -> String
lawsTypeClass :: String
, Laws -> [(String, Property)]
lawsProperties :: [(String, Property)]
}
data LawContext = LawContext
{ LawContext -> String
lawContextLawName :: String
, LawContext -> String
lawContextLawBody :: String
, LawContext -> String
lawContextTcName :: String
, LawContext -> String
lawContextTcProp :: String
, LawContext -> String
lawContextReduced :: String
}
reduced :: Show a => a -> a -> String
reduced :: forall a. Show a => a -> a -> String
reduced a
lhs a
rhs = forall a. Show a => a -> String
show a
lhs forall a. [a] -> [a] -> [a]
++ String
congruent forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
rhs
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 forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"When testing the " forall a. [a] -> [a] -> [a]
++ String
lawContextLawName forall a. [a] -> [a] -> [a]
++ String
" law(" forall a. [a] -> [a] -> [a]
++ String
dagger forall a. [a] -> [a] -> [a]
++String
"), for the " forall a. [a] -> [a] -> [a]
++ String
lawContextTcName forall a. [a] -> [a] -> [a]
++ String
" typeclass, the following test failed: "
, String
newline forall a. [a] -> [a] -> [a]
++ String
lawContextTcProp
, String
newline forall a. [a] -> [a] -> [a]
++ String
"The reduced test is: "
, String
tab2 forall a. [a] -> [a] -> [a]
++ String
lawContextReduced
, String
newline forall a. [a] -> [a] -> [a]
++ String
"The law in question: "
, String
tab2 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
dagger forall a. [a] -> [a] -> [a]
++ String
") " forall a. [a] -> [a] -> [a]
++ String
lawContextLawName forall a. [a] -> [a] -> [a]
++ String
" Law: " forall a. [a] -> [a] -> [a]
++ String
lawContextLawBody
]
lawsCheck ::
Laws
-> IO Bool
lawsCheck :: Laws -> IO Bool
lawsCheck = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. Laws -> IO All
lawsCheckInternal
lawsCheckOne ::
Gen a
-> [Gen a -> Laws]
-> IO Bool
lawsCheckOne :: forall a. Gen a -> [Gen a -> Laws] -> IO Bool
lawsCheckOne Gen a
g = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Gen a -> [Gen a -> Laws] -> IO All
lawsCheckOneInternal Gen a
g
lawsCheckMany ::
[(String, [Laws])]
-> IO Bool
lawsCheckMany :: [(String, [Laws])] -> IO Bool
lawsCheckMany = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll 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) =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m (f :: * -> *) a.
(Foldable t, Monoid m, Applicative f) =>
(a -> f m) -> t a -> f m
foldMapA [(String, Property)]
properties forall a b. (a -> b) -> a -> b
$ \(String
name,Property
p) -> do
String -> IO ()
putStr (String
className forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" ")
(String
out,Bool
b) <- forall a. IO a -> IO (String, a)
S.capture forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ (String -> String
removeBadOutput String
out) forall a. Semigroup a => a -> a -> a
<> String
"\n"
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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Laws -> IO All
lawsCheckInternal forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m (f :: * -> *) a.
(Foldable t, Monoid m, Applicative f) =>
(a -> f m) -> t a -> f m
foldMapA [(String, [Laws])]
xs forall a b. (a -> b) -> a -> b
$ \(String
typeName, [Laws]
laws) -> do
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String -> String
prettyHeader String
typeName
Status
r <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m (f :: * -> *) a.
(Foldable t, Monoid m, Applicative f) =>
(a -> f m) -> t a -> f m
foldMapA [Laws]
laws forall a b. (a -> b) -> a -> b
$ \(Laws String
typeclassName [(String, Property)]
properties) -> do
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m (f :: * -> *) a.
(Foldable t, Monoid m, Applicative f) =>
(a -> f m) -> t a -> f m
foldMapA [(String, Property)]
properties forall a b. (a -> b) -> a -> b
$ \(String
name,Property
p) -> do
String -> IO ()
putStr (String
typeclassName forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
name)
(String
out,Bool
b) <- forall a. IO a -> IO (String, a)
S.capture forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ (String -> String
removeBadOutput String
out) forall a. Semigroup a => a -> a -> a
<> String
"\n"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Status
boolToStatus Bool
b)
String -> IO ()
putStrLn String
""
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" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
Status
Bad -> do
String -> IO ()
putStrLn String
"One or more tests failed"
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 = forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f m
f)
prettyHeader :: String -> String
String
s = [String] -> String
unlines [String
topLine, String
middleLine, String
bottomLine]
where
line :: String
line = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
+ Int
6) Char
'-'
topLine :: String
topLine = String
line
bottomLine :: String
bottomLine = String
line
middleLine :: String
middleLine = String
"-- " forall a. [a] -> [a] -> [a]
++ String
s 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Seed
seed <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m Seed
Seed.random
Report Result
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) 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 <- forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress UseColor
u forall a. Maybe a
Nothing Report Progress
progress
case forall a. Report a -> a
reportStatus Report Progress
progress of
Progress
Running -> forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
Region.setRegion Region
region String
ppprogress
Shrinking FailureReport
_ -> forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
Region.openRegion Region
region String
ppprogress
String
ppresult <- forall (m :: * -> *). MonadIO m => Report Result -> m String
PP.renderResult Report Result
result
case forall a. Report a -> a
reportStatus Report Result
result of
Failed FailureReport
_ -> forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
Region.openRegion Region
region String
ppresult
Result
GaveUp -> forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
Region.openRegion Region
region String
ppresult
Result
OK -> forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
Region.setRegion Region
region String
ppresult
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m, LiftRegion m) =>
(Region -> m a) -> m a
Region.displayRegion forall a b. (a -> b) -> a -> b
$ \Region
region ->
(forall a. Eq a => a -> a -> Bool
== Result
OK) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Report a -> a
reportStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Region -> Property -> m (Report Result)
checkRegion Region
region Property
prop
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
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 = forall a. (a -> Bool) -> DPredicate a
DPredicate 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 = forall a. (a -> Bool) -> DPredicate a
DPredicate forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
False
startsWithCorner :: DPredicate String
startsWithCorner :: DPredicate String
startsWithCorner = forall a. (a -> Bool) -> DPredicate a
DPredicate forall a b. (a -> b) -> a -> b
$ \case
[] -> Bool
False
(Char
x:String
_) -> Char
x forall a. Eq a => a -> a -> Bool
== Char
'┏'
containsBar :: DPredicate String
containsBar :: DPredicate String
containsBar = forall a. (a -> Bool) -> DPredicate a
DPredicate forall a b. (a -> b) -> a -> b
$ \String
s -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Char
'┃') String
s
isBad :: String -> Bool
isBad :: String -> Bool
isBad = forall a. DPredicate a -> a -> Bool
getDPredicate forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ DPredicate String
startsWithCorner
, DPredicate String
containsBar
]
removeBadOutput :: String -> String
removeBadOutput :: String -> String
removeBadOutput = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
go 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 forall a. a -> [a] -> [a]
: [String] -> [String]
go [String]
xs