prop-unit 0.1.4 → 0.2.0
raw patch · 3 files changed
+257/−4 lines, 3 filesdep +containers
Dependencies added: containers
Files
- prop-unit.cabal +2/−1
- src/PropUnit.hs +163/−0
- test/Main.hs +92/−3
prop-unit.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: prop-unit-version: 0.1.4+version: 0.2.0 synopsis: Conveniences for using Hedgehog as a unit test runner description: Please see the README on GitHub at <https://github.com/ejconlon/prop-unit#readme> category: Testing@@ -101,6 +101,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.12 && <5+ , containers , hedgehog >=1.4 && <1.6 , prop-unit , tasty
src/PropUnit.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE UndecidableInstances #-}+ module PropUnit ( DependencyType (..) , Gen@@ -20,10 +22,25 @@ , testGroup , testMain , withResource+ , GenDefault (..)+ , genDefaultTag+ , genDefaultIntegral+ , genDefaultEnum+ , genDefaultList+ , genDefaultString+ , genDefaultGeneric+ , Std ) where +import Control.Applicative ((<|>)) import Control.Monad (when)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Proxy (Proxy (..))+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.Exts (IsList (..), IsString (..))+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..), (:+:) (..))+import GHC.TypeLits (KnownNat, Nat, natVal) import Hedgehog ( DiscardLimit , Gen@@ -44,6 +61,8 @@ , (/==) , (===) )+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range import System.Environment (lookupEnv, setEnv) import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Test.Tasty (DependencyType (..), TestName, TestTree, after, defaultMain, testGroup, withResource)@@ -82,3 +101,147 @@ testMain f = do lim <- setupTests defaultMain (f lim)++class GenDefault tag a where+ -- | Default generator for @a@+ --+ -- The type-level @tag@ allows types @a@ to have multiple defaults.+ genDefault :: Proxy tag -> Gen a++-- | DerivingVia wrapper for types with default instances under other tags+newtype ViaTag tag' a = ViaTag {unViaTag :: a}++instance (GenDefault tag' a) => GenDefault tag (ViaTag tag' a) where+ genDefault _ = fmap ViaTag (genDefault @tag' Proxy)++genDefaultTag :: forall tag a tag'. (GenDefault tag' a) => Proxy tag' -> Proxy tag -> Gen a+genDefaultTag _ _ = fmap (unViaTag @tag' @a) (genDefault (Proxy @tag))++-- | DerivingVia wrapper for Integral types+newtype ViaIntegral a = ViaIntegral {unViaIntegral :: a}++instance (Integral a, Bounded a) => GenDefault tag (ViaIntegral a) where+ genDefault _ = fmap ViaIntegral (Gen.integral (Range.constantFrom 0 minBound maxBound))++genDefaultIntegral :: forall tag a. (Integral a, Bounded a) => Proxy tag -> Gen a+genDefaultIntegral _ = fmap (unViaIntegral @a) (genDefault (Proxy @tag))++-- | DerivingVia wrapper for Enum types+newtype ViaEnum a = ViaEnum {unViaEnum :: a}++instance (Enum a, Bounded a) => GenDefault tag (ViaEnum a) where+ genDefault _ = fmap ViaEnum Gen.enumBounded++genDefaultEnum :: forall tag a. (Enum a, Bounded a) => Proxy tag -> Gen a+genDefaultEnum _ = fmap (unViaEnum @a) (genDefault (Proxy @tag))++-- | DerivingVia wrapper for FromList types+newtype ViaList a (mn :: Nat) (mx :: Nat) = ViaList {unViaList :: a}++instance (IsList a, GenDefault tag (Item a), KnownNat mn, KnownNat mx) => GenDefault tag (ViaList a mn mx) where+ genDefault p =+ let bn = fromInteger (natVal (Proxy @mn))+ bx = fromInteger (natVal (Proxy @mx))+ in fmap (ViaList . fromList) (Gen.list (Range.constant bn bx) (genDefault p))++genDefaultList+ :: forall tag a mn mx+ . (IsList a, KnownNat mn, KnownNat mx, GenDefault tag (Item a))+ => Proxy mn+ -> Proxy mx+ -> Proxy tag+ -> Gen a+genDefaultList _ _ _ = fmap (unViaList @a @mn @mx) (genDefault (Proxy @tag))++-- | DerivingVia wrapper for FromString types+newtype ViaString s (mn :: Nat) (mx :: Nat) = ViaString {unViaString :: s}++instance (IsString s, GenDefault tag Char, KnownNat mn, KnownNat mx) => GenDefault tag (ViaString s mn mx) where+ genDefault p =+ let bn = fromInteger (natVal (Proxy @mn))+ bx = fromInteger (natVal (Proxy @mx))+ in fmap (ViaString . fromString) (Gen.list (Range.constant bn bx) (genDefault p))++genDefaultString+ :: forall tag a mn mx+ . (IsString a, KnownNat mn, KnownNat mx, GenDefault tag Char)+ => Proxy mn+ -> Proxy mx+ -> Proxy tag+ -> Gen a+genDefaultString _ _ _ = fmap (unViaString @a @mn @mx) (genDefault (Proxy @tag))++class GGenDefault tag f where+ ggenDefault :: Proxy tag -> Gen (f a)++instance GGenDefault tag U1 where+ ggenDefault _ = pure U1++instance (GGenDefault tag a) => GGenDefault tag (M1 i c a) where+ ggenDefault = fmap M1 . ggenDefault++instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :*: b) where+ ggenDefault p = liftA2 (:*:) (ggenDefault p) (ggenDefault p)++instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :+: b) where+ ggenDefault p = fmap L1 (ggenDefault p) <|> fmap R1 (ggenDefault p)++instance (GenDefault tag a) => GGenDefault tag (K1 i a) where+ ggenDefault = fmap K1 . genDefault++-- | DerivingVia wrapper for Generic types+newtype ViaGeneric tag a = ViaGeneric {unViaGeneric :: a}++instance (Generic a, GGenDefault tag (Rep a)) => GenDefault tag (ViaGeneric tag a) where+ genDefault = fmap (ViaGeneric . to) . ggenDefault++genDefaultGeneric :: forall tag a. (Generic a, GGenDefault tag (Rep a)) => Proxy tag -> Gen a+genDefaultGeneric _ = fmap (unViaGeneric @tag @a) (genDefault (Proxy @tag))++-- | Type tag for these "standard" default generators.+-- You can use this tag directly or choose type-by-type with 'ViaTag'.+data Std++instance GenDefault Std () where genDefault = genDefaultEnum++instance GenDefault Std Bool where genDefault = genDefaultEnum++instance GenDefault Std Char where genDefault = genDefaultEnum++instance GenDefault Std Int where genDefault = genDefaultIntegral++instance GenDefault Std Int8 where genDefault = genDefaultIntegral++instance GenDefault Std Int16 where genDefault = genDefaultIntegral++instance GenDefault Std Int32 where genDefault = genDefaultIntegral++instance GenDefault Std Int64 where genDefault = genDefaultIntegral++instance GenDefault Std Word where genDefault = genDefaultIntegral++instance GenDefault Std Word8 where genDefault = genDefaultIntegral++instance GenDefault Std Word16 where genDefault = genDefaultIntegral++instance GenDefault Std Word32 where genDefault = genDefaultIntegral++instance GenDefault Std Word64 where genDefault = genDefaultIntegral++instance (GenDefault Std a) => GenDefault Std (Maybe a) where genDefault = genDefaultGeneric++instance (GenDefault Std a, GenDefault Std b) => GenDefault Std (Either a b) where genDefault = genDefaultGeneric++instance (GenDefault Std a, GenDefault Std b) => GenDefault Std (a, b) where genDefault = genDefaultGeneric++instance (GenDefault Std a, GenDefault Std b, GenDefault Std c) => GenDefault Std (a, b, c) where+ genDefault = genDefaultGeneric++instance (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d) => GenDefault Std (a, b, c, d) where+ genDefault = genDefaultGeneric++instance+ (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d, GenDefault Std e)+ => GenDefault Std (a, b, c, d, e)+ where+ genDefault = genDefaultGeneric
test/Main.hs view
@@ -1,8 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+ module Main (main) where +import Control.Monad (replicateM)+import Data.Proxy (Proxy (..))+import qualified Data.Set as Set+import GHC.Exts (IsList, IsString)+import GHC.Generics (Generic)+import Hedgehog (Gen) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import PropUnit (TestLimit, TestTree, forAll, testGroup, testMain, testProp, testUnit, (===))+import PropUnit+ ( GenDefault (..)+ , Std+ , TestLimit+ , TestTree+ , assert+ , forAll+ , genDefaultEnum+ , genDefaultGeneric+ , genDefaultList+ , genDefaultString+ , genDefaultTag+ , testGroup+ , testMain+ , testProp+ , testUnit+ , (===)+ ) testAsUnit :: TestTree testAsUnit = testUnit "as unit" $ do@@ -15,10 +41,73 @@ x <- forAll (Gen.int (Range.constant 1 10)) abs x * abs x === x * x +testBasic :: TestLimit -> TestTree+testBasic lim =+ testGroup+ "basic"+ [ testAsUnit+ , testAsProp lim+ ]++data Tag++instance GenDefault Tag Int where genDefault = genDefaultTag (Proxy @Std)++instance GenDefault Tag Char where genDefault = genDefaultTag (Proxy @Std)++newtype AList a = AList [a]+ deriving newtype (Eq, Ord, Show, IsList)++instance (GenDefault Tag a) => GenDefault Tag (AList a) where genDefault = genDefaultList (Proxy @0) (Proxy @2)++newtype AString = AString String+ deriving newtype (Eq, Ord, Show, IsString)++instance GenDefault Tag AString where genDefault = genDefaultString (Proxy @0) (Proxy @2)++data Choice = ChoiceA | ChoiceB+ deriving stock (Eq, Ord, Show, Enum, Bounded)++instance GenDefault Tag Choice where genDefault = genDefaultEnum++instance (GenDefault Tag a) => GenDefault Tag (Maybe a) where genDefault = genDefaultGeneric++data Record = Record !Int !(Maybe Record)+ deriving stock (Eq, Ord, Show, Generic)++instance GenDefault Tag Record where genDefault = genDefaultGeneric++data GenCase where+ GenCase :: (Ord a) => String -> Gen a -> GenCase++genDefaultByProxy :: (GenDefault Tag a) => Proxy a -> Gen a+genDefaultByProxy _ = genDefault (Proxy @Tag)++mkGenCase :: (Ord a, GenDefault Tag a) => String -> Proxy a -> GenCase+mkGenCase name = GenCase name . genDefaultByProxy++genCases :: [GenCase]+genCases =+ [ mkGenCase "Int" (Proxy @Int)+ , mkGenCase "Char" (Proxy @Char)+ , mkGenCase "Choice" (Proxy @Choice)+ , mkGenCase "AList" (Proxy @(AList Char))+ , mkGenCase "AString" (Proxy @AString)+ , mkGenCase "Record" (Proxy @Record)+ ]++testGenCase :: GenCase -> TestTree+testGenCase (GenCase name gen) = testUnit name $ do+ xs <- fmap Set.fromList (replicateM 10 (Gen.sample gen))+ assert (Set.size xs > 1)++testDerive :: TestTree+testDerive = testGroup "derive" (fmap testGenCase genCases)+ main :: IO () main = testMain $ \lim -> testGroup "PropUnit"- [ testAsUnit- , testAsProp lim+ [ testBasic lim+ , testDerive ]