-- We have (Semigroup m, Monoid m) constraints in the Semigroup/Monoid laws section.
-- this is redundant with 8.4+
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Test.Pos.Util.QuickCheck.Property
       ( -- * Various properties and predicates
         qcIsJust
       , qcIsNothing
       , qcIsLeft
       , qcIsRight
       , qcElem
       , qcNotElem
       , qcFail

       -- * Monadic properties
       , assertProperty
       , stopProperty
       , maybeStopProperty
       , splitIntoChunks
       , expectedOne

       -- * HSpec utils
       , expectationError

       -- * Generators
       , splitWord
       , sumEquals

       -- * Helpers
       , (.=.)
       , (>=.)
       , shouldThrowException

       -- * Semigroup/monoid laws
       , formsSemigroup
       , formsMonoid
       , formsCommutativeMonoid
       ) where

import           Universum

import qualified Data.Semigroup as Semigroup
import           Test.Hspec (Expectation, Selector, shouldThrow)
import           Test.QuickCheck (Property, counterexample, property, (.&&.),
                     (===))
import           Test.QuickCheck.Gen (Gen, choose)
import           Test.QuickCheck.Monadic (PropertyM, pick, stop)
import           Test.QuickCheck.Property (Result (..), failed)

----------------------------------------------------------------------------
-- Various properties and predicates
----------------------------------------------------------------------------

qcIsJust :: Maybe a -> Property
qcIsJust (Just _) = property True
qcIsJust Nothing  = qcFail "expected Just, got Nothing"

qcIsNothing :: Show a => Maybe a -> Property
qcIsNothing Nothing  = property True
qcIsNothing (Just x) = qcFail ("expected Nothing, got Just (" <> show x <> ")")

qcIsLeft :: Show b => Either a b -> Property
qcIsLeft (Left _)  = property True
qcIsLeft (Right x) = qcFail ("expected Left, got Right (" <> show x <> ")")

qcIsRight :: Show a => Either a b -> Property
qcIsRight (Right _) = property True
qcIsRight (Left x)  = qcFail ("expected Right, got Left (" <> show x <> ")")

-- TBD would it not be sufficient to just use 'Traversable'? Does the
-- 'Container' class from 'universum' add any value?
--
--   qcElem :: (Eq a, Show a, Show (t a), Traversable t) => a -> t a -> Property
--
qcElem
    :: (Show a, Eq a, Show t, Container t, Element t ~ a)
    => a -> t -> Property
qcElem x xs =
    counterexample ("expected " <> show x <> " to be in " <> show xs) $
    x `elem` xs

qcNotElem
    :: (Show a, Eq a, Show t, Container t, Element t ~ a)
    => a -> t -> Property
qcNotElem x xs =
    counterexample ("expected " <> show x <> " not to be in " <> show xs) $
    not (x `elem` xs)

-- | A property that is always false
qcFail :: Text -> Property
qcFail s = counterexample (toString s) False

----------------------------------------------------------------------------
-- Monadic testing
----------------------------------------------------------------------------

-- | Call stopProperty if boolean value is false.
assertProperty :: Monad m => Bool -> Text -> PropertyM m ()
assertProperty st text = unless st $ stopProperty text

-- Note, 'fail' does the same thing, but:
-- • it's quite trivial, almost no copy-paste;
-- • it's 'fail' from 'Monad', not 'MonadFail';
-- • I am not a fan of 'fail'.
-- | Stop 'PropertyM' execution with given reason. The property will fail.
stopProperty :: Monad m => Text -> PropertyM m a
stopProperty msg = stop failed {reason = toString msg}

-- | Use 'stopProperty' if the value is 'Nothing' or return something
-- it the value is 'Just'.
maybeStopProperty :: Monad m => Text -> Maybe a -> PropertyM m a
maybeStopProperty msg =
    \case
        Nothing -> stopProperty msg
        Just x -> pure x

-- | Split given list into chunks with size up to given value.
-- TODO: consider using `sumEquals maxSize (length items)`
splitIntoChunks :: Monad m => Word -> [a] -> PropertyM m [NonEmpty a]
splitIntoChunks 0 _ = error "splitIntoChunks: maxSize is 0"
splitIntoChunks maxSize items = do
    sizeMinus1 <- pick $ choose (0, maxSize - 1)
    let (chunk, rest) = splitAt (fromIntegral sizeMinus1 + 1) items
    case nonEmpty chunk of
        Nothing      -> return []
        Just chunkNE -> (chunkNE :) <$> splitIntoChunks maxSize rest

expectedOne :: Monad m => Text -> [a] -> PropertyM m a
expectedOne desc = \case
    [] ->  kickOut "expected exactly one element, but list is empty"
    [x] -> pure x
    _ ->   kickOut "expected exactly one element, but list contains more elements"
  where
    kickOut err = stopProperty $ err <> " (" <> desc <> ")"

----------------------------------------------------------------------------
-- Generators
----------------------------------------------------------------------------

-- | Split given integer `total` into `parts` parts
-- TODO: improve naming!
splitWord :: Word64 -> Word64 -> Gen [Word64]
splitWord total parts | total < parts =
    error $ "splitWord: can't split " <> show total <> " into " <> show parts <> " parts."
                      | otherwise = map succ . take iParts <$> ((<> replicate iParts 0) <$> (sumEquals (total `div` parts + 1) $ total - parts))
  where
    iParts = fromIntegral parts

-- | Generate list of arbitrary positive integers which sum equals given sum.
-- All elements in the list will be smaller or equal then first parameter
sumEquals :: Word64 -> Word64 -> Gen [Word64]
sumEquals 0 _ = pure []
sumEquals _ 0 = pure []
sumEquals maxEl restSum = do
    el <- choose (1, min maxEl restSum)
    (el:) <$> sumEquals maxEl (restSum - el)

expectationError :: Text -> Expectation
expectationError = fail . toString

----------------------------------------------------------------------------
-- Monoid/Semigroup laws
----------------------------------------------------------------------------

isAssociative :: (Show m, Eq m, Semigroup m) => m -> m -> m -> Property
isAssociative m1 m2 m3 =
    let assoc1 = (m1 Semigroup.<> m2) Semigroup.<> m3
        assoc2 = m1 Semigroup.<> (m2 Semigroup.<> m3)
    in assoc1 === assoc2

formsSemigroup :: (Show m, Eq m, Semigroup m) => m -> m -> m -> Property
formsSemigroup = isAssociative

hasIdentity :: (Eq m, Semigroup m, Monoid m) => m -> Property
hasIdentity m =
    let id1 = mempty Semigroup.<> m
        id2 = m Semigroup.<> mempty
    in (m == id1) .&&. (m == id2)

formsMonoid :: (Show m, Eq m, Semigroup m, Monoid m) => m -> m -> m -> Property
formsMonoid m1 m2 m3 =
    (formsSemigroup m1 m2 m3) .&&. (hasIdentity m1)

isCommutative :: (Show m, Eq m, Semigroup m) => m -> m -> Property
isCommutative m1 m2 =
    let comm1 = m1 <> m2
        comm2 = m2 <> m1
    in comm1 === comm2

formsCommutativeMonoid :: (Show m, Eq m, Semigroup m, Monoid m) => m -> m -> m -> Property
formsCommutativeMonoid m1 m2 m3 =
    (formsMonoid m1 m2 m3) .&&. (isCommutative m1 m2)

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Extensional equality combinator. Useful to express function properties as functional
-- equations.
(.=.) :: (Eq b, Show b) => (a -> b) -> (a -> b) -> a -> Property
(.=.) f g a = f a === g a

infixr 5 .=.

-- | Monadic extensional equality combinator.
(>=.)
    :: (Show (m b), Eq (m b))
    => (a -> m b)
    -> (a -> m b)
    -> a
    -> Property
(>=.) f g a = f a === g a

infixr 5 >=.

shouldThrowException
    :: (Exception e)
    => (a -> b)
    -> Selector e
    -> a
    -> Expectation
shouldThrowException action exception arg =
    (return $! action arg) `shouldThrow` exception
