property-matchers-0.2.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)

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 ()

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) (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)

  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 "bool" $ do
    True & P.bool
    try (False & P.bool) >>= \case
      Left (PropertyFailed "True" "False") -> return ()
      r -> error $ "unexpected: " <> show r


  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
          ]