unpacked-validation-0.1.0.0: test/Main.hs

{-# LANGUAGE KindSignatures #-}

module Main (main) where

import Control.Applicative
import Control.Monad (liftM)
import Data.Functor.Classes
import Data.Validation.Unpacked
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup((<>)))
import Test.QuickCheck.Classes
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen

main :: IO ()
main = lawsCheckMany myClassTests

myClassTests :: [(String, [Laws])]
myClassTests =
  [ ("Ground types", myLaws validationProxy)
--  , ("Higher-kinded types", myLaws1 validationProxy1)
  ]

myLaws
  :: (Arbitrary a, Eq a, Ord a, Show a, Read a)
  => Proxy a -> [Laws]
myLaws p =
  [ eqLaws p
  , ordLaws p
  , showReadLaws p
  ]

--myLaws1
--  :: (Arbitrary1 a, Monad a, Functor a, Applicative a, Foldable a, Traversable a, Eq1 a, Show1 a)
--  => Proxy a -> [Laws]
--myLaws1 p =
--  [ monadLaws p
--  , functorLaws p
--  , applicativeLaws p
--  , foldableLaws p
--  , traversableLaws p
--  ]

validationProxy2 :: Proxy Validation
validationProxy2 = Proxy

validationProxy1 :: Proxy (Validation Int)
validationProxy1 = Proxy

validationProxy  :: Proxy (Validation Int Int)
validationProxy  = Proxy

instance Semigroup Int where
  (<>) = (+)

instance Monoid Int where
  mempty = 0
  mappend = (+)

instance (Arbitrary a, Arbitrary b) => Arbitrary (Validation a b) where
  arbitrary = arbitrary2
  shrink = shrink2

instance Arbitrary2 Validation where
  liftArbitrary2 arbA arbB = oneof [liftM Failure arbA, liftM Success arbB]

  liftShrink2 shrA _ (Failure x)  = [ Failure  x' | x' <- shrA x ]
  liftShrink2 _ shrB (Success y)  = [ Success y' | y' <- shrB y ]

instance Arbitrary a => Arbitrary1 (Validation a) where
  liftArbitrary = liftArbitrary2 arbitrary
  liftShrink = liftShrink2 shrink