property-matchers-0.7.0.0: test/PropertyMatchersSpec.hs

{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
module PropertyMatchersSpec(spec) where

import Control.Applicative
import Control.Exception
import Control.Lens
import GHC.Generics (Generic)

import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP

import qualified PropertyMatchers as P
import PropertyMatchers (pattern (:=>), (?))

import Test.Hspec
import Test.SmallCheck hiding (over)
import Test.SmallCheck.Drivers
import qualified Test.SmallCheck.Series as SC
import Debug.RecoverRTTI (anythingToString)
import System.IO.Unsafe (unsafePerformIO)
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified Prettyprinter.Render.String as PP

data AndOrTree = And AndOrTree AndOrTree | Or AndOrTree AndOrTree | Fail String | Error String | Succeed
  deriving stock (Generic, Show)
instance Monad m => SC.Serial m AndOrTree where
andsAndOrs (And x y) = P.and (andsAndOrs x) (andsAndOrs y)
andsAndOrs (Or x y) = P.or (andsAndOrs x) (andsAndOrs y)
andsAndOrs (Fail str) = P.fail (PP.pretty str) ()
andsAndOrs (Error str) = error str
andsAndOrs Succeed = P.succeed ()

propertyFails :: P.Prop Text -> P.Prop String -> P.Prop (IO a)
propertyFails expectedProp actualProp =
  P.throws @P.PropertyException $ \(P.PropertyFailed _ (PP.renderStrict . PP.layoutCompact -> expected) (anythingToString -> actual)) ->
    expectedProp expected `P.and` actualProp actual

check :: Testable IO a => Depth -> a -> IO ()
check d e = smallCheckM d e >>= \case
  Nothing -> return ()
  Just failure -> error (show failure)

pattern PropertyFailed :: Text -> String -> P.PropertyException
pattern PropertyFailed msg actual <- P.PropertyFailed _ (PP.renderStrict . PP.layoutCompact -> msg) (either (PP.renderString . PP.layoutCompact) anythingToString -> actual)
_PropertyFailed :: Fold P.PropertyException (Text, String)
_PropertyFailed = to
  (\case
    PropertyFailed msg actual -> Just (msg, actual)
    _ -> Nothing) . folded

spec :: Spec
spec = do
  it "succeed" $ do
    P.succeed ()
    P.succeed 1
    P.succeed (\_ -> 1)
    P.succeed (error "not thrown")

  it "fail" $ do
    try (P.fail "test string" 42) >>= \case
      Left
        (PropertyFailed "test string" "42") -> return ()
      _ -> error "expected correct PropertyFailed"

  describe "and/or" $ do
    let runWithMsg t = over _Left displayException <$> try @SomeException (andsAndOrs t)
    let runWithoutMsg t = over _Left (\_ -> ()) <$> try @SomeException (andsAndOrs t)
    it "and idempotency" $ do
      check 3 $ forAll $ \x -> unsafePerformIO $
        (==) <$> runWithMsg x <*> runWithMsg (And x x)
    it "or idempotency" $ do
      check 3 $ forAll $ \x -> unsafePerformIO $
        (==) <$> runWithMsg x <*> runWithMsg (Or x x)
    it "or associativity" $ do
      check 2 $ forAll $ \x y z ->
        unsafePerformIO $ (==) <$> runWithMsg (Or x (Or y z)) <*> runWithMsg (Or (Or x y) z)
    it "and associativity" $ do
      check 2 $ forAll $ \x y z ->
        unsafePerformIO $ (==) <$> runWithMsg (And x (And y z)) <*> runWithMsg (And (And x y) z)
    it "or commutativity" $ do
      check 2 $ forAll $ \x y -> unsafePerformIO $
        (==) <$> runWithoutMsg (Or x y) <*> runWithoutMsg (Or y x)
    it "and commutativity" $ do
      check 2 $ forAll $ \x y -> unsafePerformIO $
        (==) <$> runWithoutMsg (And x y) <*> runWithoutMsg (And y x)
    it "distributivity" $ do
      check 2 $ forAll $ \x y z -> unsafePerformIO $
        (==) <$> runWithMsg (And x (Or y z)) <*> runWithMsg (Or (And x y) (And x z))

  it "fails" $ do
    P.fail "test string" 42
      & P.throws @SomeException P.succeed
    P.fail "test string" 42
      & P.throws @P.PropertyException P.succeed

  it "equals" $ do
    1 & P.equals 1
    try (1 & P.equals 2) >>= \case
      Left (PropertyFailed "2" "1") -> return ()
      r -> error $ "unexpected: " <> show r

  it "match" $ do
    Left 1 & P.match _Left ? P.equals 1
    try (Left 1 & P.match _Right ? P.equals 1) >>= \case
      Left (PropertyFailed "fold to match" "Left 1") -> return ()
      r -> error $ "unexpected: " <> show r

  describe "branch" $ do
    it "singleton" $ do
      Left 2 & P.branch
        [ P.match _Left :=> P.equals 2
        ]
      try @SomeException
        (Right 2 &
          P.branch
            [ P.match _Left :=> P.equals 2 ]
        ) >>=
          P.match _Left P.succeed
    it "commits" $ do
      try @SomeException
        (Left 1 &
          P.branch
            [ P.match _Left :=> P.equals 2
            , const P.succeed :=> P.succeed
            ]
        ) >>= P.match _Left P.succeed
    it "disjunction" $ do
      Left 1 &
        P.branch
          [ P.match _Right :=> P.equals 2
          , P.match _Left :=> P.succeed
          ]

  describe "allOf1" $ do
    it "singleton" $ do
      Left 2 & P.allOf1 _Left ? P.equals 2
    it "empty" $ propertyFails (P.equals "non-empty for fold") P.succeed $
      Left 2 & P.allOf1 _Right ? P.equals 2