either-n-0.1.0.0: test/hedgehog_tests.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

import Control.Lens (APrism', clonePrism, over, preview, review)
import Control.Monad (unless)
import Data.Functor.Identity (Identity (..))
import Data.Functor.Sum (Sum (..))
import Data.Lens.Injection
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Either3TTests (either3TTests)
import Either3Tests (either3Tests)
import GHC.Generics (Generic, (:+:) (..))
import Gens (genInt, genList, genMaybeInt, genString, genUnit)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

main :: IO ()
main = do
  hSetBuffering stdout LineBuffering
  hSetBuffering stderr LineBuffering

  result <-
    and
      <$> mapM
        checkParallel
        [ Group "Injection" injectionTests
        , Group "Generic agrees with base instances" agreementTests
        , Group "Generic default instances" genericTests
        , Group "Either3" either3Tests
        , Group "Either3T" either3TTests
        ]

  unless result exitFailure

injectionTests :: [(PropertyName, Property)]
injectionTests =
  concat
    [ prismLaws "Injection1 Either" _I1 genEither genInt
    , prismLaws "Injection1 Maybe" _I1 genMaybeInt genUnit
    , prismLaws "Injection1 Bool" _I1 Gen.bool genUnit
    , prismLaws "Injection1 Ordering" _I1 genOrdering genUnit
    , prismLaws "Injection1 List" _I1 genList genUnit
    , prismLaws "Injection1 Identity" _I1 genIdentity genInt
    , prismLaws "Injection1 Unit" _I1 genUnit genUnit
    , prismLaws "Injection1 Sum" _I1 genSum genMaybeInt
    , prismLaws "Injection1 :+:" _I1 genGenericSum genMaybeInt
    , prismLaws "Injection2 Either" _I2 genEither genString
    , prismLaws "Injection2 Maybe" _I2 genMaybeInt genInt
    , prismLaws "Injection2 Bool" _I2 Gen.bool genUnit
    , prismLaws "Injection2 Ordering" _I2 genOrdering genUnit
    , prismLaws "Injection2 List" _I2 genList genNonEmpty
    , prismLaws "Injection2 Sum" _I2 genSum genList
    , prismLaws "Injection2 :+:" _I2 genGenericSum genList
    , prismLaws "Injection3 Ordering" _I3 genOrdering genUnit
    ]

agreementTests :: [(PropertyName, Property)]
agreementTests =
  concat
    [ agree "Injection1 Either" _I1 (injection (Proxy @0)) genEither genInt
    , agree "Injection2 Either" _I2 (injection (Proxy @1)) genEither genString
    , agree "Injection1 Maybe" _I1 (injection (Proxy @0)) genMaybeInt genUnit
    , agree "Injection2 Maybe" _I2 (injection (Proxy @1)) genMaybeInt genInt
    , agree "Injection1 Bool" _I1 (injection (Proxy @0)) Gen.bool genUnit
    , agree "Injection2 Bool" _I2 (injection (Proxy @1)) Gen.bool genUnit
    , agree "Injection1 Ordering" _I1 (injection (Proxy @0)) genOrdering genUnit
    , agree "Injection2 Ordering" _I2 (injection (Proxy @1)) genOrdering genUnit
    , agree "Injection3 Ordering" _I3 (injection (Proxy @2)) genOrdering genUnit
    , agree "Injection1 List" _I1 (injection (Proxy @0)) genList genUnit
    , agree "Injection2 List" _I2 (injection (Proxy @1)) genList genNonEmpty
    ]

genericTests :: [(PropertyName, Property)]
genericTests =
  concat
    [ prismLaws "Injection1 Sum19" _I1 genSum19 genInt
    , prismLaws "Injection2 Sum19" _I2 genSum19 genUnit
    , prismLaws "Injection3 Sum19" _I3 genSum19 ((,) <$> genInt <*> Gen.bool)
    , prismLaws "Injection4 Sum19" _I4 genSum19 genString
    , prismLaws "Injection5 Sum19" _I5 genSum19 ((,,) <$> genInt <*> genInt <*> genInt)
    , prismLaws "Injection6 Sum19" _I6 genSum19 genInt
    , prismLaws "Injection7 Sum19" _I7 genSum19 genInt
    , prismLaws "Injection8 Sum19" _I8 genSum19 genInt
    , prismLaws "Injection9 Sum19" _I9 genSum19 genInt
    , prismLaws "Injection10 Sum19" _I10 genSum19 genInt
    , prismLaws "Injection11 Sum19" _I11 genSum19 genInt
    , prismLaws "Injection12 Sum19" _I12 genSum19 genInt
    , prismLaws "Injection13 Sum19" _I13 genSum19 genInt
    , prismLaws "Injection14 Sum19" _I14 genSum19 genInt
    , prismLaws "Injection15 Sum19" _I15 genSum19 genInt
    , prismLaws "Injection16 Sum19" _I16 genSum19 genInt
    , prismLaws "Injection17 Sum19" _I17 genSum19 genInt
    , prismLaws "Injection18 Sum19" _I18 genSum19 genInt
    , prismLaws "Injection19 Sum19" _I19 genSum19 genInt
    , prismLaws "Injection1 Three" _I1 genThree genInt
    , prismLaws "Injection2 Three" _I2 genThree genString
    , prismLaws "Injection3 Three" _I3 genThree Gen.bool
    , [("Injection1 Three changes type", prop_three_changes_type)]
    ]

-- Prism laws

prismLaws :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> Gen s -> Gen a -> [(PropertyName, Property)]
prismLaws name p genS genA =
  [ (fromString (name ++ " preview . review"), prop_preview_review p genA)
  , (fromString (name ++ " review . preview"), prop_review_preview p genS)
  ]

-- | @preview l (review l b) == Just b@
prop_preview_review :: (Eq a, Show a) => APrism' s a -> Gen a -> Property
prop_preview_review p genA =
  property $ do
    a <- forAll genA
    preview (clonePrism p) (review (clonePrism p) a) === Just a

-- | @preview l s == Just a ==> review l a == s@
prop_review_preview :: (Eq s, Show s) => APrism' s a -> Gen s -> Property
prop_review_preview p genS =
  property $ do
    s <- forAll genS
    maybe s (review (clonePrism p)) (preview (clonePrism p) s) === s

-- | Two prisms agree on both 'preview' and 'review'.
agree :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> APrism' s a -> Gen s -> Gen a -> [(PropertyName, Property)]
agree name p q genS genA =
  [ (fromString (name ++ " preview"), prop_agree_preview p q genS)
  , (fromString (name ++ " review"), prop_agree_review p q genA)
  ]

prop_agree_preview :: (Show s, Eq a, Show a) => APrism' s a -> APrism' s a -> Gen s -> Property
prop_agree_preview p q genS =
  property $ do
    s <- forAll genS
    preview (clonePrism p) s === preview (clonePrism q) s

prop_agree_review :: (Eq s, Show s, Show a) => APrism' s a -> APrism' s a -> Gen a -> Property
prop_agree_review p q genA =
  property $ do
    a <- forAll genA
    review (clonePrism p) a === review (clonePrism q) a

-- Generic default instances

-- | One constructor for each class, with no fields, one field, more than one field and strict fields.
data Sum19
  = S1 Int
  | S2
  | S3 Int Bool
  | S4 String
  | S5 !Int !Int !Int
  | S6 Int
  | S7 Int
  | S8 Int
  | S9 Int
  | S10 Int
  | S11 Int
  | S12 Int
  | S13 Int
  | S14 Int
  | S15 Int
  | S16 Int
  | S17 Int
  | S18 Int
  | S19 Int
  deriving (Eq, Show, Generic)

instance Injection1 Sum19 Sum19 Int Int

instance Injection2 Sum19 Sum19 () ()

instance Injection3 Sum19 Sum19 (Int, Bool) (Int, Bool)

instance Injection4 Sum19 Sum19 String String

instance Injection5 Sum19 Sum19 (Int, Int, Int) (Int, Int, Int)

instance Injection6 Sum19 Sum19 Int Int

instance Injection7 Sum19 Sum19 Int Int

instance Injection8 Sum19 Sum19 Int Int

instance Injection9 Sum19 Sum19 Int Int

instance Injection10 Sum19 Sum19 Int Int

instance Injection11 Sum19 Sum19 Int Int

instance Injection12 Sum19 Sum19 Int Int

instance Injection13 Sum19 Sum19 Int Int

instance Injection14 Sum19 Sum19 Int Int

instance Injection15 Sum19 Sum19 Int Int

instance Injection16 Sum19 Sum19 Int Int

instance Injection17 Sum19 Sum19 Int Int

instance Injection18 Sum19 Sum19 Int Int

instance Injection19 Sum19 Sum19 Int Int

-- | Each instance changes the type of its own constructor.
data Three a b c
  = Three1 a
  | Three2 b
  | Three3 c
  deriving (Eq, Show, Generic)

instance Injection1 (Three a b c) (Three a' b c) a a'

instance Injection2 (Three a b c) (Three a b' c) b b'

instance Injection3 (Three a b c) (Three a b c') c c'

prop_three_changes_type :: Property
prop_three_changes_type =
  property $ do
    a <- forAll genInt
    over _I1 show (Three1 a :: Three Int String Bool) === Three1 (show a)

-- Generators

genNonEmpty :: Gen (NonEmpty Int)
genNonEmpty = Gen.nonEmpty (Range.linear 1 10) genInt

genEither :: Gen (Either Int String)
genEither = Gen.choice [fmap Left genInt, fmap Right genString]

genOrdering :: Gen Ordering
genOrdering = Gen.enumBounded

genIdentity :: Gen (Identity Int)
genIdentity = fmap Identity genInt

genSum :: Gen (Sum Maybe [] Int)
genSum = Gen.choice [fmap InL genMaybeInt, fmap InR genList]

genGenericSum :: Gen ((Maybe :+: []) Int)
genGenericSum = Gen.choice [fmap L1 genMaybeInt, fmap R1 genList]

genSum19 :: Gen Sum19
genSum19 =
  Gen.choice
    [ S1 <$> genInt
    , pure S2
    , S3 <$> genInt <*> Gen.bool
    , S4 <$> genString
    , S5 <$> genInt <*> genInt <*> genInt
    , S6 <$> genInt
    , S7 <$> genInt
    , S8 <$> genInt
    , S9 <$> genInt
    , S10 <$> genInt
    , S11 <$> genInt
    , S12 <$> genInt
    , S13 <$> genInt
    , S14 <$> genInt
    , S15 <$> genInt
    , S16 <$> genInt
    , S17 <$> genInt
    , S18 <$> genInt
    , S19 <$> genInt
    ]

genThree :: Gen (Three Int String Bool)
genThree = Gen.choice [fmap Three1 genInt, fmap Three2 genString, fmap Three3 Gen.bool]