{-# 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
"  "

-- | For footnotes
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

-- | 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 = 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

-- | 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 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
  ]

-- | 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 = 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

-- | 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 = 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

-- | 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 = 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
prettyHeader :: String -> String
prettyHeader 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

-- 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 = 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