{-# 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
" "
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
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 :: 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
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
]
lawsCheck ::
Laws
-> IO Bool
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
lawsCheckOne ::
Gen a
-> [Gen a -> Laws]
-> IO Bool
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
lawsCheckMany ::
[(String, [Laws])]
-> IO Bool
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
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
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 { 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