{-# LANGUAGE CPP #-}
{-# LANGUAGE KindSignatures #-}

{-# OPTIONS_GHC -Wall #-}

{-| This library provides sets of properties that should hold for common
    typeclasses.

    /Note:/ on GHC < 8.6, this library uses the higher-kinded typeclasses
    ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.),
    but on GHC >= 8.6, it uses @-XQuantifiedConstraints@ to express these
    constraints more cleanly.
-}
module Test.QuickCheck.Classes.Base
  ( -- * Running
    lawsCheck
  , lawsCheckMany
  , lawsCheckOne
    -- * Properties
    -- ** Ground types
#if MIN_VERSION_base(4,7,0)
  , bitsLaws
#endif
  , eqLaws
  , substitutiveEqLaws
  , numLaws
  , integralLaws
  , ixLaws
#if MIN_VERSION_base(4,7,0)
  , isListLaws
#endif
  , monoidLaws
  , commutativeMonoidLaws
  , semigroupMonoidLaws
  , ordLaws
  , enumLaws
  , boundedEnumLaws
  , semigroupLaws
  , commutativeSemigroupLaws
  , exponentialSemigroupLaws
  , idempotentSemigroupLaws
  , rectangularBandSemigroupLaws
  , showLaws
  , showReadLaws
  , storableLaws
#if MIN_VERSION_base(4,5,0)
  , genericLaws
  , generic1Laws
#endif
#if HAVE_UNARY_LAWS
    -- ** Unary type constructors
  , alternativeLaws
  , applicativeLaws
  , contravariantLaws
  , foldableLaws
  , functorLaws
  , monadLaws
  , monadPlusLaws
  , monadZipLaws
  , traversableLaws
#endif
#if HAVE_BINARY_LAWS
    -- ** Binary type constructors
  , bifoldableLaws
  , bifunctorLaws
  , bitraversableLaws
  , categoryLaws
  , commutativeCategoryLaws
#endif
    -- * Types
  , Laws(..)
  , Proxy1(..)
  , Proxy2(..)
  ) where

--
-- re-exports
--

-- Ground Types
import Test.QuickCheck.Classes.Bits
import Test.QuickCheck.Classes.Enum
import Test.QuickCheck.Classes.Eq
import Test.QuickCheck.Classes.Num
import Test.QuickCheck.Classes.Integral
import Test.QuickCheck.Classes.Ix
#if MIN_VERSION_base(4,7,0)
import Test.QuickCheck.Classes.Base.IsList
#endif
import Test.QuickCheck.Classes.Monoid
import Test.QuickCheck.Classes.Ord
import Test.QuickCheck.Classes.Semigroup
import Test.QuickCheck.Classes.Show
import Test.QuickCheck.Classes.ShowRead
import Test.QuickCheck.Classes.Storable
#if MIN_VERSION_base(4,5,0)
import Test.QuickCheck.Classes.Generic
#endif
-- Unary type constructors
#if HAVE_UNARY_LAWS
import Test.QuickCheck.Classes.Alternative
import Test.QuickCheck.Classes.Applicative
import Test.QuickCheck.Classes.Contravariant
import Test.QuickCheck.Classes.Foldable
import Test.QuickCheck.Classes.Functor
import Test.QuickCheck.Classes.Monad
import Test.QuickCheck.Classes.MonadPlus
import Test.QuickCheck.Classes.MonadZip
import Test.QuickCheck.Classes.Traversable
#endif

-- Binary type constructors
#if HAVE_BINARY_LAWS
import Test.QuickCheck.Classes.Bifunctor
import Test.QuickCheck.Classes.Bifoldable
import Test.QuickCheck.Classes.Bitraversable
import Test.QuickCheck.Classes.Category
#if HAVE_SEMIGROUPOIDS
import Test.QuickCheck.Classes.Semigroupoid
#endif
#endif

--
-- used below
--
import Test.QuickCheck
import Test.QuickCheck.Classes.Internal (foldMapA, Laws(..))
import Control.Monad
import Data.Foldable
import Data.Monoid (Monoid(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup)
import System.Exit (exitFailure)
import qualified Data.List as List
import qualified Data.Semigroup as SG

-- | A convenience function for testing properties in GHCi.
-- For example, at GHCi:
--
-- >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering))
-- Monoid: Associative +++ OK, passed 100 tests.
-- Monoid: Left Identity +++ OK, passed 100 tests.
-- Monoid: Right Identity +++ OK, passed 100 tests.
--
-- Assuming that the 'Arbitrary' instance for 'Ordering' is good, we now
-- have confidence that the 'Monoid' instance for 'Ordering' satisfies
-- the monoid laws.
lawsCheck :: Laws -> IO ()
lawsCheck :: Laws -> IO ()
lawsCheck (Laws String
className [(String, Property)]
properties) = do
  (((String, Property) -> IO ()) -> [(String, Property)] -> IO ())
-> [(String, Property)] -> ((String, Property) -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, Property) -> IO ()) -> [(String, Property)] -> IO ()
forall (t :: * -> *) m (f :: * -> *) a.
(Foldable t, Monoid m, Semigroup m, Applicative f) =>
(a -> f m) -> t a -> f m
foldMapA [(String, Property)]
properties (((String, Property) -> IO ()) -> IO ())
-> ((String, Property) -> IO ()) -> IO ()
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
" ")
    Property -> IO ()
forall prop. Testable prop => prop -> IO ()
quickCheck Property
p

-- | A convenience function that allows one to check many typeclass
-- instances of the same type.
--
-- >>> specialisedLawsCheckMany (Proxy :: Proxy Word) [jsonLaws, showReadLaws]
-- ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests.
-- ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests.
-- Show/Read: Partial Isomorphism +++ OK, passed 100 tests.
lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO ()
lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO ()
lawsCheckOne Proxy a
p [Proxy a -> Laws]
ls = ((Proxy a -> Laws) -> IO ()) -> [Proxy a -> Laws] -> IO ()
forall (t :: * -> *) b (m :: * -> *) a.
(Foldable t, Monoid b, Monad m) =>
(a -> m b) -> t a -> m b
foldlMapM (Laws -> IO ()
lawsCheck (Laws -> IO ())
-> ((Proxy a -> Laws) -> Laws) -> (Proxy a -> Laws) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Proxy a -> Laws) -> Proxy a -> Laws
forall a b. (a -> b) -> a -> b
$ Proxy a
p)) [Proxy a -> Laws]
ls

-- | A convenience function for checking multiple typeclass instances
--   of multiple types. Consider the following Haskell source file:
--
-- @
-- import Data.Proxy (Proxy(..))
-- import Data.Map (Map)
-- import Data.Set (Set)
--
-- -- A 'Proxy' for 'Set' 'Int'.
-- setInt :: Proxy (Set Int)
-- setInt = Proxy
--
-- -- A 'Proxy' for 'Map' 'Int' 'Int'.
-- mapInt :: Proxy (Map Int Int)
-- mapInt = Proxy
--
-- myLaws :: Proxy a -> [Laws]
-- myLaws p = [eqLaws p, monoidLaws p]
--
-- namedTests :: [(String, [Laws])]
-- namedTests =
--   [ ("Set Int", myLaws setInt)
--   , ("Map Int Int", myLaws mapInt)
--   ]
-- @
--
-- Now, in GHCi:
--
-- >>> lawsCheckMany namedTests
--
-- @
-- Testing properties for common typeclasses
-- -------------
-- -- Set Int --
-- -------------
--
-- Eq: Transitive +++ OK, passed 100 tests.
-- Eq: Symmetric +++ OK, passed 100 tests.
-- Eq: Reflexive +++ OK, passed 100 tests.
-- Monoid: Associative +++ OK, passed 100 tests.
-- Monoid: Left Identity +++ OK, passed 100 tests.
-- Monoid: Right Identity +++ OK, passed 100 tests.
-- Monoid: Concatenation +++ OK, passed 100 tests.
--
-- -----------------
-- -- Map Int Int --
-- -----------------
--
-- Eq: Transitive +++ OK, passed 100 tests.
-- Eq: Symmetric +++ OK, passed 100 tests.
-- Eq: Reflexive +++ OK, passed 100 tests.
-- Monoid: Associative +++ OK, passed 100 tests.
-- Monoid: Left Identity +++ OK, passed 100 tests.
-- Monoid: Right Identity +++ OK, passed 100 tests.
-- Monoid: Concatenation +++ OK, passed 100 tests.
-- @
--
-- In the case of a failing test, the program terminates with
-- exit code 1.
lawsCheckMany ::
     [(String,[Laws])] -- ^ Element is type name paired with typeclass laws
  -> IO ()
lawsCheckMany :: [(String, [Laws])] -> IO ()
lawsCheckMany [(String, [Laws])]
xs = do
  String -> IO ()
putStrLn String
"Testing properties for common typeclasses"
  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, Semigroup 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
$ Int -> Char -> String
forall a. Int -> a -> [a]
List.replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
typeName Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6) Char
'-'
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
List.replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
typeName Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6) Char
'-'
    ((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, Semigroup 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, Semigroup 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
        Result
r <- Property -> IO Result
forall prop. Testable prop => prop -> IO Result
quickCheckResult Property
p
        Status -> IO Status
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> IO Status) -> Status -> IO Status
forall a b. (a -> b) -> a -> b
$ case Result
r of
          Success{} -> Status
Good
          Result
_ -> Status
Bad
  String -> IO ()
putStrLn String
""
  case Status
r of
    Status
Good -> String -> IO ()
putStrLn String
"All tests succeeded"
    Status
Bad -> do
      String -> IO ()
putStrLn String
"One or more tests failed"
      IO ()
forall a. IO a
exitFailure

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
  mappend :: Status -> Status -> Status
mappend = Status -> Status -> Status
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | In older versions of GHC, Proxy is not poly-kinded,
--   so we provide Proxy1.
data Proxy1 (f :: * -> *) = Proxy1

-- | In older versions of GHC, Proxy is not poly-kinded,
--   so we provide Proxy2.
data Proxy2 (f :: * -> * -> *) = Proxy2

-- This is used internally to work around a missing Monoid
-- instance for IO on older GHCs.
foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
foldlMapM :: (a -> m b) -> t a -> m b
foldlMapM a -> m b
f = (b -> a -> m b) -> b -> t a -> m b
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\b
b a
a -> (b -> b) -> m b -> m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
b) (a -> m b
f a
a)) b
forall a. Monoid a => a
mempty