diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# 0.0.1.1 + +- Added support for GHC 9.8. + +# 0.0.1 + +Initial release. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -186,7 +186,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright © 2022 Jonathan Knowles + Copyright © 2022–2023 Jonathan Knowles Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ -Quasi-unique identifiers for QuickCheck. +# `quickcheck-quid` + -![Build Status](https://github.com/jonathanknowles/quickcheck-quid/actions/workflows/haskell.yml/badge.svg) +Quasi-unique identifiers for QuickCheck. diff --git a/quickcheck-quid.cabal b/quickcheck-quid.cabal --- a/quickcheck-quid.cabal +++ b/quickcheck-quid.cabal @@ -1,12 +1,12 @@ cabal-version: 3.0 name: quickcheck-quid -version: 0.0.1 +version: 0.0.1.1 bug-reports: https://github.com/jonathanknowles/quickcheck-quid/issues license: Apache-2.0 license-file: LICENSE author: Jonathan Knowles maintainer: mail@jonathanknowles.net -copyright: 2022 Jonathan Knowles +copyright: 2022–2023 Jonathan Knowles category: Testing synopsis: Quasi-unique identifiers for QuickCheck description: @@ -16,39 +16,75 @@ https://github.com/jonathanknowles/quickcheck-quid/blob/main/README.md -extra-source-files: +extra-doc-files: + CHANGELOG.md README.md source-repository head type: git location: https://github.com/jonathanknowles/quickcheck-quid +common dependency-base + build-depends:base >= 4.14.3.0 && < 4.20 +common dependency-containers + build-depends:containers >= 0.5.7.0 && < 0.7 +common dependency-deepseq + build-depends:deepseq >= 1.4.4.0 && < 1.6 +common dependency-extra + build-depends:extra >= 1.5 && < 1.8 +common dependency-fmt + build-depends:fmt >= 0.6.1 && < 0.7 +common dependency-hashable + build-depends:hashable >= 1.3.0.0 && < 1.5 +common dependency-hspec + build-depends:hspec >= 2.7.1 && < 2.12 +common dependency-pretty-simple + build-depends:pretty-simple >= 1.0.0.0 && < 4.2 +common dependency-primes + build-depends:primes >= 0.2.0.0 && < 0.3 +common dependency-QuickCheck + build-depends:QuickCheck >= 2.14 && < 2.15 +common dependency-quickcheck-classes + build-depends:quickcheck-classes >= 0.6.2.0 && < 0.7 +common dependency-text + build-depends:text >= 1.2.3.2 && < 2.2 + library + import: + , dependency-base hs-source-dirs: - src/quickcheck-quid + src/public exposed-modules: Test.QuickCheck.Quid default-language: Haskell2010 build-depends: - base >=4.7 && <5 - , quickcheck-quid-internal + , quickcheck-quid:internal -library quickcheck-quid-example +library example + import: + , dependency-base + , dependency-QuickCheck hs-source-dirs: - src/quickcheck-quid-example + src/example exposed-modules: Test.QuickCheck.Quid.Example default-language: Haskell2010 build-depends: - QuickCheck - , base >=4.7 && <5 , quickcheck-quid -library quickcheck-quid-internal +library internal + import: + , dependency-base + , dependency-containers + , dependency-deepseq + , dependency-extra + , dependency-hashable + , dependency-QuickCheck + , dependency-text hs-source-dirs: - src/quickcheck-quid-internal + src/internal exposed-modules: Internal.Test.QuickCheck Internal.Test.QuickCheck.Quid @@ -63,19 +99,22 @@ default-language: Haskell2010 build-depends: - QuickCheck - , base >=4.7 && <5 - , containers - , deepseq - , extra - , hashable - , text -test-suite quickcheck-quid-test +test-suite test + import: + , dependency-base + , dependency-containers + , dependency-fmt + , dependency-hspec + , dependency-pretty-simple + , dependency-primes + , dependency-QuickCheck + , dependency-quickcheck-classes + , dependency-text main-is: Spec.hs hs-source-dirs: - src/quickcheck-quid-test + src/test other-modules: Test.QuickCheck.Classes.Hspec Test.QuickCheck.QuidSpec @@ -90,14 +129,5 @@ build-tool-depends: hspec-discover:hspec-discover ==2.* build-depends: - QuickCheck - , base >=4.7 && <5 - , containers - , fmt - , hspec - , pretty-simple - , primes - , quickcheck-classes , quickcheck-quid - , quickcheck-quid-internal - , text + , quickcheck-quid:internal diff --git a/src/example/Test/QuickCheck/Quid/Example.hs b/src/example/Test/QuickCheck/Quid/Example.hs new file mode 100644 --- /dev/null +++ b/src/example/Test/QuickCheck/Quid/Example.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Test.QuickCheck.Quid.Example where + +import GHC.Generics + ( Generic ) +import Test.QuickCheck + ( Arbitrary, CoArbitrary, Function ) +import Test.QuickCheck.Quid + ( Decimal (..), Hexadecimal (..), Latin (..), Quid, Size (..) ) + +newtype FooId = FooId (Decimal Quid) + deriving stock (Eq, Generic, Ord, Read, Show) + deriving Arbitrary via Size 256 Quid + deriving CoArbitrary via Quid + deriving anyclass Function + deriving newtype Num + +newtype BarId = BarId (Hexadecimal Quid) + deriving stock (Eq, Generic, Ord, Read, Show) + deriving Arbitrary via Size 256 Quid + deriving CoArbitrary via Quid + deriving anyclass Function + deriving newtype Num + +newtype BazId = BazId (Latin Quid) + deriving stock (Eq, Generic, Ord, Read, Show) + deriving Arbitrary via Size 256 Quid + deriving CoArbitrary via Quid + deriving anyclass Function diff --git a/src/internal/Internal/Test/QuickCheck.hs b/src/internal/Internal/Test/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck.hs @@ -0,0 +1,19 @@ +module Internal.Test.QuickCheck where + +import Data.List.NonEmpty + ( NonEmpty ) +import Data.Maybe + ( mapMaybe ) +import Test.QuickCheck + ( shrinkList ) + +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE + +-------------------------------------------------------------------------------- +-- Shrinking +-------------------------------------------------------------------------------- + +shrinkListNonEmpty :: (a -> [a]) -> NonEmpty a -> [NonEmpty a] +shrinkListNonEmpty shrinkFn = + mapMaybe NE.nonEmpty . shrinkList shrinkFn . F.toList diff --git a/src/internal/Internal/Test/QuickCheck/Quid.hs b/src/internal/Internal/Test/QuickCheck/Quid.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Internal.Test.QuickCheck.Quid + where + +import Control.DeepSeq + ( NFData ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import GHC.Generics + ( Generic ) +import Numeric.Natural + ( Natural ) +import Test.QuickCheck + ( Arbitrary (..) + , CoArbitrary (..) + , Function (..) + , Gen + , chooseInteger + , coarbitraryShow + , functionMap + , shrinkMapBy + , sized + ) +import Test.QuickCheck.Function + ( (:->) ) + +import qualified Data.List as L + +-------------------------------------------------------------------------------- +-- Quids +-------------------------------------------------------------------------------- + +newtype Quid = Quid + { unQuid :: Natural } + deriving (Data, Eq, Generic, Ord) + deriving newtype (Hashable, NFData, Num) + +instance Arbitrary Quid where + arbitrary = arbitraryQuid + shrink = shrinkQuid + +instance CoArbitrary Quid where + coarbitrary = coarbitraryQuid + +instance Function Quid where + function = functionQuid + +-------------------------------------------------------------------------------- +-- Generation and shrinking of arbitrary quids +-------------------------------------------------------------------------------- + +arbitraryQuid :: Gen Quid +arbitraryQuid = sized $ \i -> chooseQuid (Quid 0, Quid $ (2 ^ max 0 i) - 1) + +chooseQuid :: (Quid, Quid) -> Gen Quid +chooseQuid (Quid n1, Quid n2) = Quid <$> chooseNatural (n1, n2) + +coarbitraryQuid :: Quid -> Gen a -> Gen a +coarbitraryQuid = coarbitraryShow . unQuid + +functionQuid :: (Quid -> a) -> Quid :-> a +functionQuid = functionMap (show . unQuid) (Quid . read) + +shrinkQuid :: Quid -> [Quid] +shrinkQuid = shrinkMapBy Quid unQuid shrinkNatural + +-------------------------------------------------------------------------------- +-- Conversion between quids and natural numbers +-------------------------------------------------------------------------------- + +naturalToQuid :: Natural -> Quid +naturalToQuid = Quid + +quidToNatural :: Quid -> Natural +quidToNatural = unQuid + +-------------------------------------------------------------------------------- +-- Natural number support +-------------------------------------------------------------------------------- + +chooseNatural :: (Natural, Natural) -> Gen Natural +chooseNatural (p, q) = fromIntegral @Integer @Natural <$> + chooseInteger (fromIntegral p, fromIntegral q) + +shrinkNatural :: Natural -> [Natural] +shrinkNatural n + | n == 0 = [] + | otherwise = L.nub $ 0 : as <> bs + where + as = takeWhile (<= n `div` 2) (iterate (* 2) 1) + bs = (n -) <$> reverse as diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Internal.Test.QuickCheck.Quid.Combinators.Chunk + where + +import Control.DeepSeq + ( NFData ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import Data.List.Extra + ( chunksOf ) +import Data.Proxy + ( Proxy (..) ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal ) + +import qualified Data.List as L + +-------------------------------------------------------------------------------- +-- Chunk combinator +-------------------------------------------------------------------------------- + +newtype Chunk (n :: Nat) (s :: Symbol) a = Chunk { unChunk :: a } + deriving (Data, Eq, Generic, Hashable, NFData, Ord) + +instance (KnownNat n, KnownSymbol s, Show a) => Show (Chunk n s a) where + show (Chunk a) + = L.intercalate (symbolVal (Proxy @s)) + $ chunksOf (fromIntegral $ natVal $ Proxy @n) + $ show a diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Internal.Test.QuickCheck.Quid.Combinators.Prefix + where + +import Control.Applicative + ( many ) +import Control.DeepSeq + ( NFData ) +import Control.Monad + ( void ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import Data.Proxy + ( Proxy (..) ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( KnownSymbol, Symbol, symbolVal ) +import Internal.Text.Read + ( skipChar, skipString ) +import Text.Read + ( Read (..) ) + +-------------------------------------------------------------------------------- +-- Prefixes +-------------------------------------------------------------------------------- + +newtype Prefix (prefix :: Symbol) a = Prefix { unPrefix :: a } + deriving (Data, Eq, Generic, Hashable, NFData, Ord) + +instance (KnownSymbol prefix, Read a) => Read (Prefix prefix a) where + readPrec = do + void $ many $ skipChar ' ' + skipString $ symbolVal $ Proxy @prefix + Prefix <$> readPrec @a + +instance (KnownSymbol prefix, Show a) => Show (Prefix prefix a) where + show (Prefix a) = symbolVal (Proxy @prefix) <> show a diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Internal.Test.QuickCheck.Quid.Combinators.Size + where + +import Control.DeepSeq + ( NFData ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import Data.Proxy + ( Proxy (..) ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( KnownNat, Nat, natVal ) +import Test.QuickCheck + ( Arbitrary (..), resize, shrinkMapBy ) + +-------------------------------------------------------------------------------- +-- Sizes +-------------------------------------------------------------------------------- + +newtype Size (n :: Nat) a = Size { unSize :: a } + deriving (Data, Eq, Generic, Hashable, NFData, Ord) + deriving (Read, Show) via a + +instance (Arbitrary a, KnownNat n) => Arbitrary (Size n a) where + arbitrary = Size <$> resize (fromIntegral $ natVal $ Proxy @n) arbitrary + shrink = shrinkMapBy Size unSize shrink diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Representations.hs b/src/internal/Internal/Test/QuickCheck/Quid/Representations.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Representations.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Internal.Test.QuickCheck.Quid.Representations + where + +import Data.List.NonEmpty + ( NonEmpty ) +import Data.Proxy + ( Proxy (..) ) +import Internal.Test.QuickCheck.Quid + ( Quid (..) ) +import Numeric.Natural + ( Natural ) + +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE + +nonEmptyListToQuid :: forall a. (Bounded a, Enum a) => NonEmpty a -> Quid +nonEmptyListToQuid xs = Quid $ + F.foldl' f 0 xs - 1 + where + f !acc !x = acc * base + 1 + fromIntegral (fromEnum x) + base = fromIntegral @Int @Natural $ boundedEnumCardinality $ Proxy @a + +nonEmptyListFromQuid :: forall a. (Bounded a, Enum a) => Quid -> NonEmpty a +nonEmptyListFromQuid (Quid q) = + NE.fromList $ go [] q + where + go :: [a] -> Natural -> [a] + go !acc !n + | n < base = + toEnum (fromIntegral n) : acc + | otherwise = + go (toEnum (fromIntegral (n `mod` base)) : acc) (n `div` base - 1) + base = fromIntegral @Int @Natural $ boundedEnumCardinality $ Proxy @a + +boundedEnumCardinality :: forall a. (Bounded a, Enum a) => Proxy a -> Int +boundedEnumCardinality _ = fromEnum (maxBound @a) - fromEnum (minBound @a) + 1 diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Internal.Test.QuickCheck.Quid.Representations.Decimal + ( Decimal (..) + ) + where + +import Control.DeepSeq + ( NFData ) +import Data.Bifunctor + ( first ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import GHC.Generics + ( Generic ) +import Internal.Test.QuickCheck.Quid + ( Quid (..) ) +import Numeric + ( showInt ) +import Numeric.Natural + ( Natural ) +import Test.QuickCheck + ( Function ) +import Text.ParserCombinators.ReadP + ( readP_to_S, skipSpaces ) +import Text.Read.Lex + ( readDecP ) + +-------------------------------------------------------------------------------- +-- Decimal representation +-------------------------------------------------------------------------------- + +newtype Decimal a = Decimal { unDecimal :: a } + deriving stock (Data, Eq, Generic, Ord) + deriving newtype (Hashable, NFData, Num) + deriving anyclass Function + +deriving via AsDecimal Natural instance Read (Decimal Quid) +deriving via AsDecimal Natural instance Show (Decimal Quid) + +newtype AsDecimal a = AsDecimal a + +instance (Eq a, Num a) => Read (AsDecimal a) where + readsPrec _ = fmap (first AsDecimal) <$> readP_to_S (skipSpaces >> readDecP) + +instance (Integral a, Show a) => Show (AsDecimal a) where + show (AsDecimal n) = showInt n "" diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Internal.Test.QuickCheck.Quid.Representations.Hexadecimal + ( Hexadecimal (..) + ) + where + +import Control.DeepSeq + ( NFData ) +import Data.Bifunctor + ( first ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import GHC.Generics + ( Generic ) +import Internal.Test.QuickCheck.Quid + ( Quid (..) ) +import Internal.Test.QuickCheck.Quid.Combinators.Prefix + ( Prefix (..) ) +import Numeric + ( readHex, showHex ) +import Numeric.Natural + ( Natural ) +import Test.QuickCheck + ( Function ) + +-------------------------------------------------------------------------------- +-- Hexadecimal representation +-------------------------------------------------------------------------------- + +newtype Hexadecimal a = Hexadecimal { unHexadecimal :: a } + deriving stock (Data, Eq, Generic, Ord) + deriving newtype (Hashable, NFData, Num) + deriving anyclass Function + +deriving via Prefix "0x" (AsHex Natural) instance Read (Hexadecimal Quid) +deriving via Prefix "0x" (AsHex Natural) instance Show (Hexadecimal Quid) + +newtype AsHex a = AsHex a + +instance (Eq a, Num a) => Read (AsHex a) where + readsPrec _ = fmap (first AsHex) <$> readHex + +instance (Integral a, Show a) => Show (AsHex a) where + show (AsHex n) = showHex n "" diff --git a/src/internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Internal.Test.QuickCheck.Quid.Representations.Latin + where + +import Control.DeepSeq + ( NFData ) +import Control.Monad + ( replicateM ) +import Data.Char + ( ord ) +import Data.Data + ( Data ) +import Data.Hashable + ( Hashable (..) ) +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Maybe + ( fromMaybe ) +import Data.String + ( IsString (..) ) +import GHC.Generics + ( Generic ) +import Internal.Test.QuickCheck + ( shrinkListNonEmpty ) +import Internal.Test.QuickCheck.Quid + ( Quid (..) ) +import Internal.Test.QuickCheck.Quid.Representations + ( nonEmptyListFromQuid, nonEmptyListToQuid ) +import Test.QuickCheck + ( Arbitrary (..) + , Function + , Gen + , arbitraryBoundedEnum + , shrinkMap + , shrinkMapBy + , sized + ) +import Text.Read + ( Read (..), readMaybe ) + +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE + +-------------------------------------------------------------------------------- +-- Latin representation +-------------------------------------------------------------------------------- + +newtype Latin a = Latin { unLatin :: a } + deriving stock (Data, Eq, Generic, Ord) + deriving newtype (Hashable, NFData) + deriving anyclass Function + +instance Read (Latin Quid) where + readPrec = fromString <$> readPrec + +instance Show (Latin Quid) where + show = show . latinStringFromQuid . unLatin + +instance IsString (Latin Quid) where + fromString = Latin . latinStringToQuid . fromString + +-------------------------------------------------------------------------------- +-- Latin characters +-------------------------------------------------------------------------------- + +data LatinChar + = A | B | C | D | E | F | G | H | I | J | K | L | M + | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + deriving (Bounded, Enum, Eq, Ord, Read, Show) + +instance Arbitrary LatinChar where + arbitrary = arbitraryLatinChar + shrink = shrinkLatinChar + +-------------------------------------------------------------------------------- +-- Generation and shrinking of arbitrary Latin characters +-------------------------------------------------------------------------------- + +arbitraryLatinChar :: Gen LatinChar +arbitraryLatinChar = arbitraryBoundedEnum + +shrinkLatinChar :: LatinChar -> [LatinChar] +shrinkLatinChar = shrinkMap toEnum fromEnum + +-------------------------------------------------------------------------------- +-- Conversion between Latin characters and ordinary characters +-------------------------------------------------------------------------------- + +charToLatinChar :: Char -> Maybe LatinChar +charToLatinChar c = readMaybe [c] + +latinCharToChar :: LatinChar -> Char +latinCharToChar = toEnum . (+ ord 'A') . fromEnum + +-------------------------------------------------------------------------------- +-- Latin strings +-------------------------------------------------------------------------------- + +newtype LatinString = LatinString + { unLatinString :: NonEmpty LatinChar } + deriving stock (Eq, Ord) + deriving newtype Semigroup + +instance Arbitrary LatinString where + arbitrary = arbitraryLatinString + shrink = shrinkLatinString + +-------------------------------------------------------------------------------- +-- Conversion between Latin strings and ordinary strings +-------------------------------------------------------------------------------- + +instance Read LatinString where + readPrec = fromString <$> readPrec + +instance Show LatinString where + show = show . latinStringToString + +instance IsString LatinString where + fromString = unsafeStringtoLatinString + +latinStringToString :: LatinString -> String +latinStringToString (LatinString cs) = F.foldMap show cs + +stringToLatinString :: String -> Maybe LatinString +stringToLatinString s = + LatinString <$> (NE.nonEmpty =<< traverse charToLatinChar s) + +unsafeStringtoLatinString :: String -> LatinString +unsafeStringtoLatinString = fromMaybe raiseError . stringToLatinString + where + raiseError = error $ unwords + [ "A Latin quid string must be composed of one or more uppercase" + , "characters in the range [A-Z]." + ] + +-------------------------------------------------------------------------------- +-- Generation and shrinking of arbitrary Latin strings +-------------------------------------------------------------------------------- + +arbitraryLatinString :: Gen LatinString +arbitraryLatinString = sized $ \size -> + fmap LatinString . (:|) + <$> arbitraryLatinChar + <*> replicateM size arbitraryLatinChar + +shrinkLatinString :: LatinString -> [LatinString] +shrinkLatinString = + shrinkMapBy LatinString unLatinString $ shrinkListNonEmpty shrinkLatinChar + +-------------------------------------------------------------------------------- +-- Conversion between Latin strings and quids +-------------------------------------------------------------------------------- + +latinStringToQuid :: LatinString -> Quid +latinStringToQuid = nonEmptyListToQuid . unLatinString + +latinStringFromQuid :: Quid -> LatinString +latinStringFromQuid = LatinString . nonEmptyListFromQuid diff --git a/src/internal/Internal/Text/Read.hs b/src/internal/Internal/Text/Read.hs new file mode 100644 --- /dev/null +++ b/src/internal/Internal/Text/Read.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE LambdaCase #-} + +module Internal.Text.Read where + +import Control.Monad + ( replicateM_ ) +import Text.Read + ( ReadPrec, get, look, pfail ) + +import qualified Data.List as L + +readCharMaybe :: (Char -> Maybe a) -> ReadPrec a +readCharMaybe f = look >>= \case + a : _ | Just c <- f a -> + get >> pure c + _ -> + pfail + +skipChar :: Char -> ReadPrec () +skipChar charToSkip = readCharMaybe + (\char -> if char == charToSkip then Just () else Nothing) + +skipString :: String -> ReadPrec () +skipString stringToSkip = do + remainder <- look + if stringToSkip `L.isPrefixOf` remainder + then replicateM_ (length stringToSkip) get + else pfail diff --git a/src/public/Test/QuickCheck/Quid.hs b/src/public/Test/QuickCheck/Quid.hs new file mode 100644 --- /dev/null +++ b/src/public/Test/QuickCheck/Quid.hs @@ -0,0 +1,29 @@ +module Test.QuickCheck.Quid + ( + -- * The Quid type + Quid + + -- * Combinators + , Size (..) + + -- * Representations + + -- ** Numerical representations + , Decimal (..) + , Hexadecimal (..) + + -- ** String representations + , Latin (..) + ) + where + +import Internal.Test.QuickCheck.Quid + ( Quid (..) ) +import Internal.Test.QuickCheck.Quid.Combinators.Size + ( Size (..) ) +import Internal.Test.QuickCheck.Quid.Representations.Decimal + ( Decimal (..) ) +import Internal.Test.QuickCheck.Quid.Representations.Hexadecimal + ( Hexadecimal (..) ) +import Internal.Test.QuickCheck.Quid.Representations.Latin + ( Latin (..) ) diff --git a/src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs b/src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs deleted file mode 100644 --- a/src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Test.QuickCheck.Quid.Example where - -import GHC.Generics - ( Generic ) -import Test.QuickCheck - ( Arbitrary, CoArbitrary, Function ) -import Test.QuickCheck.Quid - ( Decimal (..), Hexadecimal (..), Latin (..), Quid, Size (..) ) - -newtype ExampleDecimalQuid = ExampleDecimalQuid (Decimal Quid) - deriving stock (Eq, Generic, Ord, Read, Show) - deriving Arbitrary via (Size 256 Quid) - deriving CoArbitrary via Quid - deriving anyclass Function - deriving newtype Num - -newtype ExampleHexadecimalQuid = ExampleHexadecimalQuid (Hexadecimal Quid) - deriving stock (Eq, Generic, Ord, Read, Show) - deriving Arbitrary via (Size 256 Quid) - deriving CoArbitrary via Quid - deriving anyclass Function - deriving newtype Num - -newtype ExampleLatinQuid = ExampleLatinQuid (Latin Quid) - deriving stock (Eq, Generic, Ord, Read, Show) - deriving Arbitrary via (Size 256 Quid) - deriving CoArbitrary via Quid - deriving anyclass Function diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Internal.Test.QuickCheck where - -import Data.List.NonEmpty - ( NonEmpty ) -import Data.Maybe - ( mapMaybe ) -import Test.QuickCheck - ( shrinkList ) - -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE - --------------------------------------------------------------------------------- --- Shrinking --------------------------------------------------------------------------------- - -shrinkListNonEmpty :: (a -> [a]) -> NonEmpty a -> [NonEmpty a] -shrinkListNonEmpty shrinkFn = - mapMaybe NE.nonEmpty . shrinkList shrinkFn . F.toList diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -module Internal.Test.QuickCheck.Quid - where - -import Control.DeepSeq - ( NFData ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import GHC.Generics - ( Generic ) -import Numeric.Natural - ( Natural ) -import Test.QuickCheck - ( Arbitrary (..) - , CoArbitrary (..) - , Function (..) - , Gen - , chooseInteger - , coarbitraryShow - , functionMap - , shrinkMapBy - , sized - ) -import Test.QuickCheck.Function - ( (:->) ) - -import qualified Data.List as L - --------------------------------------------------------------------------------- --- Quids --------------------------------------------------------------------------------- - -newtype Quid = Quid - { unQuid :: Natural } - deriving (Data, Eq, Generic, Ord) - deriving newtype (Hashable, NFData, Num) - -instance Arbitrary Quid where - arbitrary = arbitraryQuid - shrink = shrinkQuid - -instance CoArbitrary Quid where - coarbitrary = coarbitraryQuid - -instance Function Quid where - function = functionQuid - --------------------------------------------------------------------------------- --- Generation and shrinking of arbitrary quids --------------------------------------------------------------------------------- - -arbitraryQuid :: Gen Quid -arbitraryQuid = sized $ \i -> chooseQuid (Quid 0, Quid $ (2 ^ max 0 i) - 1) - -chooseQuid :: (Quid, Quid) -> Gen Quid -chooseQuid (Quid n1, Quid n2) = Quid <$> chooseNatural (n1, n2) - -coarbitraryQuid :: Quid -> Gen a -> Gen a -coarbitraryQuid = coarbitraryShow . unQuid - -functionQuid :: (Quid -> a) -> Quid :-> a -functionQuid = functionMap (show . unQuid) (Quid . read) - -shrinkQuid :: Quid -> [Quid] -shrinkQuid = shrinkMapBy Quid unQuid shrinkNatural - --------------------------------------------------------------------------------- --- Conversion between quids and natural numbers --------------------------------------------------------------------------------- - -naturalToQuid :: Natural -> Quid -naturalToQuid = Quid - -quidToNatural :: Quid -> Natural -quidToNatural = unQuid - --------------------------------------------------------------------------------- --- Natural number support --------------------------------------------------------------------------------- - -chooseNatural :: (Natural, Natural) -> Gen Natural -chooseNatural (p, q) = fromIntegral @Integer @Natural <$> - chooseInteger (fromIntegral p, fromIntegral q) - -shrinkNatural :: Natural -> [Natural] -shrinkNatural n - | n == 0 = [] - | otherwise = L.nub $ 0 : as <> bs - where - as = takeWhile (<= n `div` 2) (iterate (* 2) 1) - bs = (n -) <$> reverse as diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Internal.Test.QuickCheck.Quid.Combinators.Chunk - where - -import Control.DeepSeq - ( NFData ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import Data.List.Extra - ( chunksOf ) -import Data.Proxy - ( Proxy (..) ) -import GHC.Generics - ( Generic ) -import GHC.TypeLits - ( KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal ) - -import qualified Data.List as L - --------------------------------------------------------------------------------- --- Chunk combinator --------------------------------------------------------------------------------- - -newtype Chunk (n :: Nat) (s :: Symbol) a = Chunk { unChunk :: a } - deriving (Data, Eq, Generic, Hashable, NFData, Ord) - -instance (KnownNat n, KnownSymbol s, Show a) => Show (Chunk n s a) where - show (Chunk a) - = L.intercalate (symbolVal (Proxy @s)) - $ chunksOf (fromIntegral $ natVal $ Proxy @n) - $ show a diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Internal.Test.QuickCheck.Quid.Combinators.Prefix - where - -import Control.Applicative - ( many ) -import Control.DeepSeq - ( NFData ) -import Control.Monad - ( void ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import Data.Proxy - ( Proxy (..) ) -import GHC.Generics - ( Generic ) -import GHC.TypeLits - ( KnownSymbol, Symbol, symbolVal ) -import Internal.Text.Read - ( skipChar, skipString ) -import Text.Read - ( Read (..) ) - --------------------------------------------------------------------------------- --- Prefixes --------------------------------------------------------------------------------- - -newtype Prefix (prefix :: Symbol) a = Prefix { unPrefix :: a } - deriving (Data, Eq, Generic, Hashable, NFData, Ord) - -instance (KnownSymbol prefix, Read a) => Read (Prefix prefix a) where - readPrec = do - void $ many $ skipChar ' ' - skipString $ symbolVal $ Proxy @prefix - Prefix <$> readPrec @a - -instance (KnownSymbol prefix, Show a) => Show (Prefix prefix a) where - show (Prefix a) = symbolVal (Proxy @prefix) <> show a diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Internal.Test.QuickCheck.Quid.Combinators.Size - where - -import Control.DeepSeq - ( NFData ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import Data.Proxy - ( Proxy (..) ) -import GHC.Generics - ( Generic ) -import GHC.TypeLits - ( KnownNat, Nat, natVal ) -import Test.QuickCheck - ( Arbitrary (..), resize, shrinkMapBy ) - --------------------------------------------------------------------------------- --- Sizes --------------------------------------------------------------------------------- - -newtype Size (n :: Nat) a = Size { unSize :: a } - deriving (Data, Eq, Generic, Hashable, NFData, Ord) - deriving (Read, Show) via a - -instance (Arbitrary a, KnownNat n) => Arbitrary (Size n a) where - arbitrary = Size <$> resize (fromIntegral $ natVal $ Proxy @n) arbitrary - shrink = shrinkMapBy Size unSize shrink diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Internal.Test.QuickCheck.Quid.Representations - where - -import Data.List.NonEmpty - ( NonEmpty ) -import Data.Proxy - ( Proxy (..) ) -import Internal.Test.QuickCheck.Quid - ( Quid (..) ) -import Numeric.Natural - ( Natural ) - -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE - -nonEmptyListToQuid :: forall a. (Bounded a, Enum a) => NonEmpty a -> Quid -nonEmptyListToQuid xs = Quid $ - F.foldl' f 0 xs - 1 - where - f !acc !x = acc * base + 1 + fromIntegral (fromEnum x) - base = fromIntegral @Int @Natural $ boundedEnumCardinality $ Proxy @a - -nonEmptyListFromQuid :: forall a. (Bounded a, Enum a) => Quid -> NonEmpty a -nonEmptyListFromQuid (Quid q) = - NE.fromList $ go [] q - where - go :: [a] -> Natural -> [a] - go !acc !n - | n < base = - toEnum (fromIntegral n) : acc - | otherwise = - go (toEnum (fromIntegral (n `mod` base)) : acc) (n `div` base - 1) - base = fromIntegral @Int @Natural $ boundedEnumCardinality $ Proxy @a - -boundedEnumCardinality :: forall a. (Bounded a, Enum a) => Proxy a -> Int -boundedEnumCardinality _ = fromEnum (maxBound @a) - fromEnum (minBound @a) + 1 diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Internal.Test.QuickCheck.Quid.Representations.Decimal - ( Decimal (..) - ) - where - -import Control.DeepSeq - ( NFData ) -import Data.Bifunctor - ( first ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import GHC.Generics - ( Generic ) -import Internal.Test.QuickCheck.Quid - ( Quid (..) ) -import Numeric - ( showInt ) -import Numeric.Natural - ( Natural ) -import Test.QuickCheck - ( Function ) -import Text.ParserCombinators.ReadP - ( readP_to_S, skipSpaces ) -import Text.Read.Lex - ( readDecP ) - --------------------------------------------------------------------------------- --- Decimal representation --------------------------------------------------------------------------------- - -newtype Decimal a = Decimal { unDecimal :: a } - deriving stock (Data, Eq, Generic, Ord) - deriving newtype (Hashable, NFData, Num) - deriving anyclass Function - -deriving via AsDecimal Natural instance Read (Decimal Quid) -deriving via AsDecimal Natural instance Show (Decimal Quid) - -newtype AsDecimal a = AsDecimal a - -instance (Eq a, Num a) => Read (AsDecimal a) where - readsPrec _ = fmap (first AsDecimal) <$> readP_to_S (skipSpaces >> readDecP) - -instance (Integral a, Show a) => Show (AsDecimal a) where - show (AsDecimal n) = showInt n "" diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Internal.Test.QuickCheck.Quid.Representations.Hexadecimal - ( Hexadecimal (..) - ) - where - -import Control.DeepSeq - ( NFData ) -import Data.Bifunctor - ( first ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import GHC.Generics - ( Generic ) -import Internal.Test.QuickCheck.Quid - ( Quid (..) ) -import Internal.Test.QuickCheck.Quid.Combinators.Prefix - ( Prefix (..) ) -import Numeric - ( readHex, showHex ) -import Numeric.Natural - ( Natural ) -import Test.QuickCheck - ( Function ) - --------------------------------------------------------------------------------- --- Hexadecimal representation --------------------------------------------------------------------------------- - -newtype Hexadecimal a = Hexadecimal { unHexadecimal :: a } - deriving stock (Data, Eq, Generic, Ord) - deriving newtype (Hashable, NFData, Num) - deriving anyclass Function - -deriving via Prefix "0x" (AsHex Natural) instance Read (Hexadecimal Quid) -deriving via Prefix "0x" (AsHex Natural) instance Show (Hexadecimal Quid) - -newtype AsHex a = AsHex a - -instance (Eq a, Num a) => Read (AsHex a) where - readsPrec _ = fmap (first AsHex) <$> readHex - -instance (Integral a, Show a) => Show (AsHex a) where - show (AsHex n) = showHex n "" diff --git a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Internal.Test.QuickCheck.Quid.Representations.Latin - where - -import Control.DeepSeq - ( NFData ) -import Control.Monad - ( replicateM ) -import Data.Data - ( Data ) -import Data.Hashable - ( Hashable (..) ) -import Data.List.NonEmpty - ( NonEmpty (..) ) -import Data.Maybe - ( fromMaybe ) -import Data.String - ( IsString (..) ) -import GHC.Generics - ( Generic ) -import Internal.Test.QuickCheck - ( shrinkListNonEmpty ) -import Internal.Test.QuickCheck.Quid - ( Quid (..) ) -import Internal.Test.QuickCheck.Quid.Representations - ( nonEmptyListFromQuid, nonEmptyListToQuid ) -import Test.QuickCheck - ( Arbitrary (..) - , Function - , Gen - , arbitraryBoundedEnum - , shrinkMap - , shrinkMapBy - , sized - ) -import Text.Read - ( Read (..), readMaybe ) - -import qualified Data.Foldable as F -import qualified Data.List.NonEmpty as NE - --------------------------------------------------------------------------------- --- Latin representation --------------------------------------------------------------------------------- - -newtype Latin a = Latin { unLatin :: a } - deriving stock (Data, Eq, Generic, Ord) - deriving newtype (Hashable, NFData) - deriving anyclass Function - -instance Read (Latin Quid) where - readPrec = fromString <$> readPrec - -instance Show (Latin Quid) where - show = show . latinStringFromQuid . unLatin - -instance IsString (Latin Quid) where - fromString = Latin . latinStringToQuid . fromString - --------------------------------------------------------------------------------- --- Latin characters --------------------------------------------------------------------------------- - -data LatinChar - = A | B | C | D | E | F | G | H | I | J | K | L | M - | N | O | P | Q | R | S | T | U | V | W | X | Y | Z - deriving (Bounded, Enum, Eq, Ord, Read, Show) - -instance Arbitrary LatinChar where - arbitrary = arbitraryLatinChar - shrink = shrinkLatinChar - --------------------------------------------------------------------------------- --- Generation and shrinking of arbitrary Latin characters --------------------------------------------------------------------------------- - -arbitraryLatinChar :: Gen LatinChar -arbitraryLatinChar = arbitraryBoundedEnum - -shrinkLatinChar :: LatinChar -> [LatinChar] -shrinkLatinChar = shrinkMap toEnum fromEnum - --------------------------------------------------------------------------------- --- Conversion between Latin characters and ordinary characters --------------------------------------------------------------------------------- - -charToLatinChar :: Char -> Maybe LatinChar -charToLatinChar c = readMaybe [c] - -latinCharToChar :: LatinChar -> Char -latinCharToChar = head . show - --------------------------------------------------------------------------------- --- Latin strings --------------------------------------------------------------------------------- - -newtype LatinString = LatinString - { unLatinString :: NonEmpty LatinChar } - deriving stock (Eq, Ord) - deriving newtype Semigroup - -instance Arbitrary LatinString where - arbitrary = arbitraryLatinString - shrink = shrinkLatinString - --------------------------------------------------------------------------------- --- Conversion between Latin strings and ordinary strings --------------------------------------------------------------------------------- - -instance Read LatinString where - readPrec = fromString <$> readPrec - -instance Show LatinString where - show = show . latinStringToString - -instance IsString LatinString where - fromString = unsafeStringtoLatinString - -latinStringToString :: LatinString -> String -latinStringToString (LatinString cs) = F.foldMap show cs - -stringToLatinString :: String -> Maybe LatinString -stringToLatinString s = - LatinString <$> (NE.nonEmpty =<< traverse charToLatinChar s) - -unsafeStringtoLatinString :: String -> LatinString -unsafeStringtoLatinString = fromMaybe raiseError . stringToLatinString - where - raiseError = error $ unwords - [ "A Latin quid string must be composed of one or more uppercase" - , "characters in the range [A-Z]." - ] - --------------------------------------------------------------------------------- --- Generation and shrinking of arbitrary Latin strings --------------------------------------------------------------------------------- - -arbitraryLatinString :: Gen LatinString -arbitraryLatinString = sized $ \size -> - fmap LatinString . (:|) - <$> arbitraryLatinChar - <*> replicateM size arbitraryLatinChar - -shrinkLatinString :: LatinString -> [LatinString] -shrinkLatinString = - shrinkMapBy LatinString unLatinString $ shrinkListNonEmpty shrinkLatinChar - --------------------------------------------------------------------------------- --- Conversion between Latin strings and quids --------------------------------------------------------------------------------- - -latinStringToQuid :: LatinString -> Quid -latinStringToQuid = nonEmptyListToQuid . unLatinString - -latinStringFromQuid :: Quid -> LatinString -latinStringFromQuid = LatinString . nonEmptyListFromQuid diff --git a/src/quickcheck-quid-internal/Internal/Text/Read.hs b/src/quickcheck-quid-internal/Internal/Text/Read.hs deleted file mode 100644 --- a/src/quickcheck-quid-internal/Internal/Text/Read.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Internal.Text.Read where - -import Control.Monad - ( replicateM_ ) -import Text.Read - ( ReadPrec, get, look, pfail ) - -import qualified Data.List as L - -readCharMaybe :: (Char -> Maybe a) -> ReadPrec a -readCharMaybe f = look >>= \case - a : _ | Just c <- f a -> - get >> pure c - _ -> - pfail - -skipChar :: Char -> ReadPrec () -skipChar charToSkip = readCharMaybe - (\char -> if char == charToSkip then Just () else Nothing) - -skipString :: String -> ReadPrec () -skipString stringToSkip = do - remainder <- look - if stringToSkip `L.isPrefixOf` remainder - then replicateM_ (length stringToSkip) get - else pfail diff --git a/src/quickcheck-quid-test/Spec.hs b/src/quickcheck-quid-test/Spec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/quickcheck-quid-test/Test/Hspec/Unit.hs b/src/quickcheck-quid-test/Test/Hspec/Unit.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/Hspec/Unit.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Test.Hspec.Unit where - -import Control.Monad - ( forM_ ) -import Test.Hspec - ( Spec, describe, it ) -import Test.QuickCheck - ( property, (===) ) -import Text.Pretty.Simple - ( pShow ) - -import qualified Data.Text.Lazy as TL - --------------------------------------------------------------------------------- --- Unit test support --------------------------------------------------------------------------------- - -data UnitTestData params result = UnitTestData - { params :: params - , result :: result - } - deriving (Eq, Show) - -unitTests - :: (Eq result, Show result) - => String - -> (params -> result) - -> [UnitTestData params result] - -> Spec -unitTests title f unitTestData = - describe title $ - forM_ (zip testNumbers unitTestData) $ - \(testNumber :: Int, test) -> do - let subtitle = "Unit test #" <> show testNumber - it subtitle $ - let resultExpected = result test in - let resultActual = f (params test) in - property $ Pretty resultExpected === Pretty resultActual - where - testNumbers :: [Int] - testNumbers = [1 ..] - --------------------------------------------------------------------------------- --- Pretty-printing --------------------------------------------------------------------------------- - --- | A combinator that causes the output of `show` to be pretty-printed. --- -newtype Pretty a = Pretty { unPretty :: a } - deriving Eq - -instance Show a => Show (Pretty a) where - show (Pretty a) = TL.unpack ("\n" <> pShow a <> "\n") diff --git a/src/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- Provides testing functions to check that type class instances obey laws. --- -module Test.QuickCheck.Classes.Hspec - ( testLaws - , testLawsMany - ) where - -import Prelude - -import Control.Monad - ( forM_ ) -import Data.Proxy - ( Proxy (..) ) -import Data.Typeable - ( Typeable, typeRep ) -import Test.Hspec - ( Spec, describe, it, parallel ) -import Test.QuickCheck.Classes - ( Laws (..) ) - --- | Constructs a test to check that the given type class instance obeys the --- given set of laws. --- --- Example usage: --- --- >>> testLaws @Natural ordLaws --- >>> testLaws @(Map Int) functorLaws --- -testLaws - :: forall a. Typeable a - => (Proxy a -> Laws) - -> Spec -testLaws getLaws = - parallel $ describe description $ - forM_ (lawsProperties laws) $ uncurry it - where - description = mconcat - [ "Testing " - , lawsTypeclass laws - , " laws for type " - , show (typeRep $ Proxy @a) - ] - laws = getLaws $ Proxy @a - --- | Calls `testLaws` with multiple sets of laws. --- --- Example usage: --- --- >>> testLawsMany @Natural [eqLaws, ordLaws] --- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws] --- -testLawsMany - :: forall a. Typeable a - => [Proxy a -> Laws] - -> Spec -testLawsMany getLawsMany = - testLaws @a `mapM_` getLawsMany diff --git a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.QuickCheck.Quid.Combinators.PrefixSpec - where - -import Internal.Test.QuickCheck.Quid.Combinators.Prefix - ( Prefix (..) ) -import Test.Hspec - ( Spec, describe, parallel ) -import Test.QuickCheck - ( Arbitrary (..), shrinkMapBy ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) - -import qualified Test.QuickCheck.Classes as Laws - -spec :: Spec -spec = do - - parallel $ describe "Lawfulness of type class instances" $ do - testLawsMany @(Prefix "A" Int) - [ Laws.showLaws - , Laws.showReadLaws - ] - testLawsMany @(Prefix ":" Int) - [ Laws.showLaws - , Laws.showReadLaws - ] - testLawsMany @(Prefix "1" Int) - [ Laws.showLaws - , Laws.showReadLaws - ] - testLawsMany @(Prefix "test-prefix:" Int) - [ Laws.showLaws - , Laws.showReadLaws - ] - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -instance Arbitrary a => Arbitrary (Prefix p a) where - arbitrary = Prefix <$> arbitrary - shrink = shrinkMapBy Prefix unPrefix shrink diff --git a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.QuickCheck.Quid.Representations.DecimalSpec - where - -import Internal.Test.QuickCheck.Quid - ( Quid, naturalToQuid ) -import Internal.Test.QuickCheck.Quid.Representations.Decimal - ( Decimal (..) ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe, parallel ) -import Test.Hspec.Unit - ( UnitTestData (..), unitTests ) -import Test.QuickCheck - ( Arbitrary (..) ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) - -import Prelude hiding - ( (^) ) - -import qualified Prelude -import qualified Test.QuickCheck.Classes as Laws - -spec :: Spec -spec = do - - parallel $ describe "Lawfulness of type class instances" $ do - testLawsMany @(Decimal Quid) - [ Laws.showLaws - , Laws.showReadLaws - ] - - parallel $ describe "Unit tests" $ do - unitTests_show_decimal_naturalToQuid - --------------------------------------------------------------------------------- --- Unit tests --------------------------------------------------------------------------------- - -unitTests_show_decimal_naturalToQuid :: Spec -unitTests_show_decimal_naturalToQuid = unitTests - "unitTests_show_decimal_naturalToQuid" - (show . Decimal . naturalToQuid) - (mkTest <$> tests) - where - mkTest :: (Natural, String) -> UnitTestData Natural String - mkTest (params, result) = UnitTestData {params, result} - - (^) :: Natural -> Natural -> Natural - (^) = (Prelude.^) - - tests = - [ (0, "0") - , (1, "1") - , (8, "8") - , (9, "9") - - , (10^0, "1") - , (10^1, "10") - , (10^2, "100") - , (10^3, "1000") - , (10^4, "10000") - , (10^5, "100000") - , (10^6, "1000000") - , (10^7, "10000000") - - , (10^0 - 1, "0") - , (10^1 - 1, "9") - , (10^2 - 1, "99") - , (10^3 - 1, "999") - , (10^4 - 1, "9999") - , (10^5 - 1, "99999") - , (10^6 - 1, "999999") - , (10^7 - 1, "9999999") - ] - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -deriving via Quid instance Arbitrary (Decimal Quid) diff --git a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.QuickCheck.Quid.Representations.HexadecimalSpec - where - -import Internal.Test.QuickCheck.Quid - ( Quid, naturalToQuid ) -import Internal.Test.QuickCheck.Quid.Representations.Hexadecimal - ( Hexadecimal (..) ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe, parallel ) -import Test.Hspec.Unit - ( UnitTestData (..), unitTests ) -import Test.QuickCheck - ( Arbitrary (..) ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) - -import Prelude hiding - ( (^) ) - -import qualified Prelude -import qualified Test.QuickCheck.Classes as Laws - -spec :: Spec -spec = do - - parallel $ describe "Lawfulness of type class instances" $ do - testLawsMany @(Hexadecimal Quid) - [ Laws.showLaws - , Laws.showReadLaws - ] - - parallel $ describe "Unit tests" $ do - unitTests_show_hexadecimal_naturalToQuid - --------------------------------------------------------------------------------- --- Unit tests --------------------------------------------------------------------------------- - -unitTests_show_hexadecimal_naturalToQuid :: Spec -unitTests_show_hexadecimal_naturalToQuid = unitTests - "unitTests_show_hexadecimal_naturalToQuid" - (show . Hexadecimal . naturalToQuid) - (mkTest <$> tests) - where - mkTest :: (Natural, String) -> UnitTestData Natural String - mkTest (params, result) = UnitTestData {params, result} - - (^) :: Natural -> Natural -> Natural - (^) = (Prelude.^) - - tests = - [ ( 0, "0x0") - , ( 1, "0x1") - , (14, "0xe") - , (15, "0xf") - - , (16 + 0, "0x10") - , (16 + 1, "0x11") - , (16 + 14, "0x1e") - , (16 + 15, "0x1f") - - , (2 * 16 + 0, "0x20") - , (2 * 16 + 1, "0x21") - , (2 * 16 + 14, "0x2e") - , (2 * 16 + 15, "0x2f") - - , (15 * 16 + 0, "0xf0") - , (15 * 16 + 1, "0xf1") - , (15 * 16 + 14, "0xfe") - , (15 * 16 + 15, "0xff") - - , (16^0, "0x1") - , (16^1, "0x10") - , (16^2, "0x100") - , (16^3, "0x1000") - , (16^4, "0x10000") - , (16^5, "0x100000") - , (16^6, "0x1000000") - , (16^7, "0x10000000") - - , (16^0 - 1, "0x0") - , (16^1 - 1, "0xf") - , (16^2 - 1, "0xff") - , (16^3 - 1, "0xfff") - , (16^4 - 1, "0xffff") - , (16^5 - 1, "0xfffff") - , (16^6 - 1, "0xffffff") - , (16^7 - 1, "0xfffffff") - ] - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -deriving via Quid instance Arbitrary (Hexadecimal Quid) diff --git a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Test.QuickCheck.Quid.Representations.LatinSpec - where - -import Internal.Test.QuickCheck.Quid - ( Quid, arbitraryQuid, naturalToQuid, shrinkQuid ) -import Internal.Test.QuickCheck.Quid.Representations.Latin - ( Latin (..), LatinString ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe, it, parallel ) -import Test.Hspec.Unit - ( UnitTestData (..), unitTests ) -import Test.QuickCheck - ( Arbitrary (..), Property, property, shrinkMapBy, (===) ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) - -import Prelude hiding - ( (^) ) - -import qualified Prelude -import qualified Test.QuickCheck.Classes as Laws - -spec :: Spec -spec = do - - parallel $ describe "Lawfulness of type class instances" $ do - testLawsMany @(Latin Quid) - [ Laws.showLaws - , Laws.showReadLaws - ] - - parallel $ describe "Round-trip tests" $ do - it "Roundtrip between Latin strings and quids" $ - property prop_roundTrip_LatinString_Quid - - parallel $ describe "Unit tests" $ do - unitTests_show_latin_naturalToQuid - --------------------------------------------------------------------------------- --- Properties --------------------------------------------------------------------------------- - -prop_roundTrip_LatinString_Quid :: LatinString -> Property -prop_roundTrip_LatinString_Quid latinString = - show (read @(Latin Quid) expectedOutput) === expectedOutput - where - expectedOutput :: String - expectedOutput = show latinString - --------------------------------------------------------------------------------- --- Unit tests --------------------------------------------------------------------------------- - -unitTests_show_latin_naturalToQuid :: Spec -unitTests_show_latin_naturalToQuid = unitTests - "unitTests_show_latin_naturalToQuid" - (show . Latin . naturalToQuid) - (mkTest <$> tests) - where - mkTest :: (Natural, String) -> UnitTestData Natural String - mkTest (params, result) = UnitTestData {params, result = show result} - - (^) :: Natural -> Natural -> Natural - (^) = (Prelude.^) - - tests = - [ ( 0, "A") - , ( 1, "B") - , (24, "Y") - , (25, "Z") - - , (26 + 0, "AA") - , (26 + 1, "AB") - , (26 + 24, "AY") - , (26 + 25, "AZ") - - , (2 * 26 + 0, "BA") - , (2 * 26 + 1, "BB") - , (2 * 26 + 24, "BY") - , (2 * 26 + 25, "BZ") - - , (26 * 26 + 0, "ZA") - , (26 * 26 + 1, "ZB") - , (26 * 26 + 24, "ZY") - , (26 * 26 + 25, "ZZ") - - , (26 , "AA") - , (26 + 26^2 , "AAA") - , (26 + 26^2 + 26^3 , "AAAA") - , (26 + 26^2 + 26^3 + 26^4 , "AAAAA") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 , "AAAAAA") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 , "AAAAAAA") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7, "AAAAAAAA") - - , (26 - 1, "Z") - , (26 + 26^2 - 1, "ZZ") - , (26 + 26^2 + 26^3 - 1, "ZZZ") - , (26 + 26^2 + 26^3 + 26^4 - 1, "ZZZZ") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 - 1, "ZZZZZ") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 - 1, "ZZZZZZ") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7 - 1, "ZZZZZZZ") - , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7 + 26^8 - 1, "ZZZZZZZZ") - ] - --------------------------------------------------------------------------------- --- Arbitrary instances --------------------------------------------------------------------------------- - -instance Arbitrary (Latin Quid) where - arbitrary = Latin <$> arbitraryQuid - shrink = shrinkMapBy Latin unLatin shrinkQuid diff --git a/src/quickcheck-quid-test/Test/QuickCheck/QuidSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/QuidSpec.hs deleted file mode 100644 --- a/src/quickcheck-quid-test/Test/QuickCheck/QuidSpec.hs +++ /dev/null @@ -1,525 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Test.QuickCheck.QuidSpec - where - -import Control.Arrow - ( (&&&) ) -import Control.Monad - ( replicateM ) -import Data.Functor - ( (<&>) ) -import Data.Maybe - ( fromMaybe ) -import Data.Numbers.Primes - ( primes ) -import Data.Ord - ( Down (..) ) -import Data.Set - ( Set ) -import Data.Text.Lazy.Builder - ( Builder, fromLazyText ) -import Fmt - ( Buildable (..), indentF, padLeftF, pretty, (+|), (|+) ) -import Internal.Test.QuickCheck.Quid - ( Quid - , arbitraryQuid - , chooseNatural - , naturalToQuid - , quidToNatural - , shrinkNatural - ) -import Internal.Test.QuickCheck.Quid.Combinators.Size - ( Size (..) ) -import Internal.Test.QuickCheck.Quid.Representations.Decimal - ( Decimal (..) ) -import Numeric.Natural - ( Natural ) -import Test.Hspec - ( Spec, describe, it, parallel ) -import Test.QuickCheck - ( Arbitrary (..) - , Fixed (..) - , Gen - , Property - , Testable (..) - , checkCoverage - , conjoin - , counterexample - , cover - , forAllBlind - , label - , liftShrink2 - , oneof - , property - , resize - , shrinkMapBy - , withMaxSuccess - , (.&&.) - , (===) - ) -import Test.QuickCheck.Classes.Hspec - ( testLawsMany ) -import Text.Pretty.Simple - ( pShow ) - -import qualified Data.List as L -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Test.QuickCheck.Classes as Laws - -spec :: Spec -spec = do - - parallel $ describe "Lawfulness of type class instances" $ do - testLawsMany @TestQuid - [ Laws.eqLaws - , Laws.ordLaws - ] - testLawsMany @TestQuid - [ Laws.eqLaws - , Laws.ordLaws - , Laws.showLaws - , Laws.showReadLaws - ] - - parallel $ describe "Uniformity" $ do - it "prop_arbitraryQuid_uniform" $ - property prop_arbitraryQuid_uniform - - parallel $ describe "Uniqueness" $ do - it "prop_arbitraryQuid_unique" $ - property prop_arbitraryQuid_unique - - parallel $ describe "Shrinkability" $ do - it "prop_shrinkQuid_lessThan" $ - property prop_shrinkQuid_lessThan - it "prop_shrinkQuid_minimalElement" $ - property prop_shrinkQuid_minimalElement - it "prop_shrinkQuid_minimalSet" $ - property prop_shrinkQuid_minimalSet - it "prop_shrinkQuid_ordered" $ - property prop_shrinkQuid_ordered - it "prop_shrinkQuid_unique" $ - property prop_shrinkQuid_unique - --------------------------------------------------------------------------------- --- Powers of two --------------------------------------------------------------------------------- - -newtype PowerOfTwo = PowerOfTwo {powerOfTwoExponent :: Natural} - deriving (Eq, Ord, Show) - -instance Buildable PowerOfTwo where - build (PowerOfTwo e) = "2^" <> build (show e) - -evalPowerOfTwo :: PowerOfTwo -> Natural -evalPowerOfTwo = (2 ^) . powerOfTwoExponent - -genPowerOfTwo :: (Natural, Natural) -> Gen PowerOfTwo -genPowerOfTwo (lo, hi) = PowerOfTwo <$> chooseNatural (lo, hi) - -shrinkPowerOfTwo :: PowerOfTwo -> [PowerOfTwo] -shrinkPowerOfTwo = shrinkMapBy PowerOfTwo powerOfTwoExponent shrinkNatural - --------------------------------------------------------------------------------- --- Prime numbers --------------------------------------------------------------------------------- - -newtype PrimeNumber = PrimeNumber {primeNumberIndex :: Natural} - deriving (Eq, Ord, Show) - -instance Buildable PrimeNumber where - build = build . show . evalPrimeNumber - -evalPrimeNumber :: PrimeNumber -> Natural -evalPrimeNumber = indexToPrime primes . primeNumberIndex - where - indexToPrime ps i - | i == 0 = head ps - | otherwise = indexToPrime (drop 1 ps) (i - 1) - -genPrimeNumber :: (Natural, Natural) -> Gen PrimeNumber -genPrimeNumber (lo, hi) = PrimeNumber <$> chooseNatural (lo, hi) - -shrinkPrimeNumber :: PrimeNumber -> [PrimeNumber] -shrinkPrimeNumber = shrinkMapBy PrimeNumber primeNumberIndex shrinkNatural - --------------------------------------------------------------------------------- --- Partition functions --------------------------------------------------------------------------------- - -data PartitionFunction - = Div PowerOfTwo - | Mod PrimeNumber - deriving (Eq, Ord, Show) - -instance Buildable PartitionFunction where - build = \case - Div p -> "div " <> padLeftF 5 ' ' p - Mod p -> "mod " <> padLeftF 5 ' ' p - -evalPartitionFunction :: PartitionFunction -> (Natural -> Natural) -evalPartitionFunction = \case - Div p -> (`div` evalPowerOfTwo p) - Mod p -> (`mod` evalPrimeNumber p) - --------------------------------------------------------------------------------- --- Partition contexts --------------------------------------------------------------------------------- - -data PartitionContext = PartitionContext - { sizeExponent :: PowerOfTwo - , expectedBucketCount :: Natural - , partitionFunction :: PartitionFunction - } - deriving (Eq, Ord, Show) - -instance Buildable PartitionContext where - build c = mconcat - [ "(size = " - , padLeftF 5 ' ' (sizeExponent c) - , ", expected bucket count = " - , padLeftF 3 ' ' (show $ expectedBucketCount c) - , ", partition function = " - , build (partitionFunction c) - , ")" - ] - --------------------------------------------------------------------------------- --- Div partitions --------------------------------------------------------------------------------- - -data DivPartition = DivPartition - { divArgument :: PowerOfTwo - , scaleFactor :: PowerOfTwo - } - deriving (Eq, Ord, Show) - -evalDivPartition :: DivPartition -> PartitionContext -evalDivPartition DivPartition {divArgument, scaleFactor} = - PartitionContext - { sizeExponent = PowerOfTwo - $ powerOfTwoExponent divArgument - + powerOfTwoExponent scaleFactor - , expectedBucketCount = evalPowerOfTwo scaleFactor - , partitionFunction = Div divArgument - } - -genDivPartition :: Gen DivPartition -genDivPartition = do - divArgument <- oneof (genPowerOfTwo <$> [(0, 1), (2, 256)]) - scaleFactor <- oneof (genPowerOfTwo <$> [(0, 1), (2, 8)]) - pure DivPartition {divArgument, scaleFactor} - -shrinkDivPartition :: DivPartition -> [DivPartition] -shrinkDivPartition = shrinkMapBy unTuple toTuple $ - liftShrink2 shrinkPowerOfTwo shrinkPowerOfTwo - where - unTuple (c, s) = (DivPartition c s) - toTuple (DivPartition c s) = (c, s) - --------------------------------------------------------------------------------- --- Mod partitions --------------------------------------------------------------------------------- - -data ModPartition = ModPartition - { modArgument :: PrimeNumber - , scaleFactor :: PowerOfTwo - } - deriving (Eq, Ord, Show) - -evalModPartition :: ModPartition -> PartitionContext -evalModPartition ModPartition {modArgument, scaleFactor} = - PartitionContext - { sizeExponent = PowerOfTwo - $ primeNumberIndex modArgument - + powerOfTwoExponent scaleFactor - + 8 - , expectedBucketCount = evalPrimeNumber modArgument - , partitionFunction = Mod modArgument - } - -genModPartition :: Gen ModPartition -genModPartition = do - modArgument <- oneof (genPrimeNumber <$> [(0, 1), (2, 32)]) - scaleFactor <- oneof (genPowerOfTwo <$> [(0, 1), (2, 256)]) - pure ModPartition {modArgument, scaleFactor} - -shrinkModPartition :: ModPartition -> [ModPartition] -shrinkModPartition = shrinkMapBy unTuple toTuple $ - liftShrink2 shrinkPrimeNumber shrinkPowerOfTwo - where - unTuple (m, s) = (ModPartition m s) - toTuple (ModPartition m s) = (m, s) - --------------------------------------------------------------------------------- --- Partitions --------------------------------------------------------------------------------- - -data Partition - = DivPartitionOf DivPartition - | ModPartitionOf ModPartition - deriving (Eq, Ord, Show) - -instance Arbitrary Partition where - arbitrary = genPartition - shrink = shrinkPartition - -evalPartition :: Partition -> PartitionContext -evalPartition = \case - DivPartitionOf p -> evalDivPartition p - ModPartitionOf p -> evalModPartition p - -genPartition :: Gen Partition -genPartition = oneof - [ DivPartitionOf <$> genDivPartition - , ModPartitionOf <$> genModPartition - ] - -shrinkPartition :: Partition -> [Partition] -shrinkPartition = \case - DivPartitionOf p -> DivPartitionOf <$> shrinkDivPartition p - ModPartitionOf p -> ModPartitionOf <$> shrinkModPartition p - --------------------------------------------------------------------------------- --- Uniformity --------------------------------------------------------------------------------- - -prop_arbitraryQuid_uniform :: Partition -> Property -prop_arbitraryQuid_uniform p = - label (pretty partitionContext) $ - forAllBlind arbitraryValues prop - where - partitionContext :: PartitionContext - partitionContext@PartitionContext - { sizeExponent - , expectedBucketCount - , partitionFunction - } = evalPartition p - - valueToBucket :: Quid -> Natural - valueToBucket = (evalPartitionFunction partitionFunction) . quidToNatural - - arbitraryValue :: Gen Quid - arbitraryValue = - resize (fromIntegral (powerOfTwoExponent sizeExponent)) arbitraryQuid - - arbitraryValues :: Gen [Quid] - arbitraryValues = - replicateM (fromIntegral arbitraryValueCount) arbitraryValue - - arbitraryValueCount :: Natural - arbitraryValueCount = unFrequency expectedFrequency * expectedBucketCount - - expectedFrequency :: Frequency - expectedFrequency = Frequency 1024 - - minimumPermittedFrequency :: Frequency - minimumPermittedFrequency = expectedFrequency <&> ((* 3) . (`div` 4)) - - maximumPermittedFrequency :: Frequency - maximumPermittedFrequency = expectedFrequency <&> ((* 5) . (`div` 4)) - - prop :: [Quid] -> Property - prop values = reports $ checks $ property True - where - reports - = report sizeExponent - "size exponent" - . report arbitraryValueCount - "arbitrary value count" - . report expectedBucketCount - "expected bucket count" - . report occupiedBucketCount - "occupied bucket count" - . report expectedFrequency - "expected frequency" - . report minimumObservedFrequency - "minimum observed frequency" - . report minimumPermittedFrequency - "minimum permitted frequency" - . report maximumObservedFrequency - "maximum observed frequency" - . report maximumPermittedFrequency - "maximum permitted frequency" - checks - = check - (occupiedBucketCount == expectedBucketCount) - "occupiedBucketCount == expectedBucketCount" - . check - (minimumObservedFrequency >= minimumPermittedFrequency) - "minimumObservedFrequency >= minimumPermittedFrequency" - . check - (maximumObservedFrequency <= maximumPermittedFrequency) - "maximumObservedFrequency <= maximumPermittedFrequency" - - occupiedBuckets :: [Natural] - occupiedBuckets = valueToBucket <$> values - - occupiedBucketFrequencies :: [(Natural, Frequency)] - occupiedBucketFrequencies = frequencies occupiedBuckets - - occupiedBucketCount :: Natural - occupiedBucketCount = fromIntegral $ length occupiedBucketFrequencies - - minimumObservedFrequency :: Frequency - minimumObservedFrequency = snd $ last occupiedBucketFrequencies - - maximumObservedFrequency :: Frequency - maximumObservedFrequency = snd $ head occupiedBucketFrequencies - --------------------------------------------------------------------------------- --- Uniqueness --------------------------------------------------------------------------------- - -prop_arbitraryQuid_unique :: Property -prop_arbitraryQuid_unique = - withMaxSuccess 1 $ - forAllBlind arbitraryFixedSizeQuids $ \uids -> - Set.size (Set.fromList uids) === L.length uids - where - arbitraryFixedSizeQuids :: Gen [TestQuid] - arbitraryFixedSizeQuids = fmap (unSize . getFixed) <$> - replicateM 1_000_000 (arbitrary @(Fixed (Size 256 TestQuid))) - --------------------------------------------------------------------------------- --- Shrinkability --------------------------------------------------------------------------------- - -prop_shrinkQuid_lessThan :: Size 256 TestQuid -> Property -prop_shrinkQuid_lessThan (Size q) = - property $ all (< q) (shrink q) - -prop_shrinkQuid_minimalElement :: TestQuid -> Property -prop_shrinkQuid_minimalElement q = - checkCoverage $ - cover 10 (q /= minimalQuid) "q /= minimalQuid" $ - case shrink q of - s : _ -> s === minimalQuid - _ -> q === minimalQuid - where - minimalQuid = TestQuid 0 - -prop_shrinkQuid_minimalSet :: [Size 256 TestQuid] -> Property -prop_shrinkQuid_minimalSet qs = - label (show $ bucket expectedSize) $ - counterexample (show expectedSize) $ - counterexample (show minimalSet) $ - conjoin - [ Set.toList minimalSet `L.isPrefixOf` allQuids - , Set.size minimalSet == expectedSize - ] - where - allQuids :: [TestQuid] - allQuids = TestQuid . naturalToQuid <$> [0 ..] - - bucket :: Int -> (Int, Int) - bucket size = (lo, hi) - where - lo = size `div` 10 * 10 - hi = lo + 9 - - expectedSize :: Int - expectedSize = L.length qs - - minimalSet :: Set TestQuid - minimalSet = Set.map unSize $ fromMaybe - (error "Cannot shrink to minimal set") - (shrinkWhile ((>= expectedSize) . Set.size) shrink (Set.fromList qs)) - -prop_shrinkQuid_ordered :: Size 256 TestQuid -> Property -prop_shrinkQuid_ordered (Size q) = - L.sort shrunkValues === shrunkValues - where - shrunkValues = shrink q - -prop_shrinkQuid_unique :: Size 256 TestQuid -> Property -prop_shrinkQuid_unique (Size q) = - Set.size (Set.fromList shrunkValues) === L.length shrunkValues - where - shrunkValues = shrink q - --------------------------------------------------------------------------------- --- Shrinking --------------------------------------------------------------------------------- - -shrinkWhile :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a -shrinkWhile condition shrinkFn = loop - where - loop a - | condition a = - case L.find condition (shrinkFn a) of - Nothing -> Just a - Just a' -> loop a' - | otherwise = - Nothing - --------------------------------------------------------------------------------- --- Frequencies --------------------------------------------------------------------------------- - -type Frequency = FrequencyOf Natural - -newtype FrequencyOf a = Frequency {unFrequency :: a} - deriving (Eq, Functor, Ord, Show) - -instance Semigroup Frequency where - Frequency f1 <> Frequency f2 = Frequency (f1 + f2) - -instance Monoid Frequency where - mempty = Frequency 1 - -frequencies :: (Foldable f, Ord k) => f k -> [(k, Frequency)] -frequencies - = L.sortOn ((Down . snd) &&& fst) - . Map.toList - . L.foldr (flip (Map.insertWith (<>)) mempty) Map.empty - --------------------------------------------------------------------------------- --- Reporting --------------------------------------------------------------------------------- - --- | Adds a named variable to the counterexample output of a property. --- --- On failure, uses pretty-printing to show the contents of the variable. --- -report :: (Show a, Testable prop) => a -> String -> prop -> Property -report a name = counterexample $ - "" +| name |+ ":\n" +| indentF 4 (pShowBuilder a) |+ "" - where - pShowBuilder :: Show a => a -> Builder - pShowBuilder = fromLazyText . pShow - --------------------------------------------------------------------------------- --- Verification --------------------------------------------------------------------------------- - --- | Adds a named condition to a property. --- --- On failure, reports the name of the condition that failed. --- -check :: Bool -> String -> Property -> Property -check condition conditionTitle = - (.&&.) (counterexample counterexampleText $ property condition) - where - counterexampleText = "Condition violated: " <> conditionTitle - --------------------------------------------------------------------------------- --- Test types --------------------------------------------------------------------------------- - -newtype TestQuid = TestQuid Quid - deriving (Read, Show) via (Decimal Quid) - deriving Arbitrary via Quid - deriving stock (Eq, Ord) diff --git a/src/quickcheck-quid/Test/QuickCheck/Quid.hs b/src/quickcheck-quid/Test/QuickCheck/Quid.hs deleted file mode 100644 --- a/src/quickcheck-quid/Test/QuickCheck/Quid.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Test.QuickCheck.Quid - ( - -- * The Quid type - Quid - - -- * Combinators - , Size (..) - - -- * Representations - - -- ** Numerical representations - , Decimal (..) - , Hexadecimal (..) - - -- ** String representations - , Latin (..) - ) - where - -import Internal.Test.QuickCheck.Quid - ( Quid (..) ) -import Internal.Test.QuickCheck.Quid.Combinators.Size - ( Size (..) ) -import Internal.Test.QuickCheck.Quid.Representations.Decimal - ( Decimal (..) ) -import Internal.Test.QuickCheck.Quid.Representations.Hexadecimal - ( Hexadecimal (..) ) -import Internal.Test.QuickCheck.Quid.Representations.Latin - ( Latin (..) ) diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/test/Test/Hspec/Unit.hs b/src/test/Test/Hspec/Unit.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/Hspec/Unit.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Hspec.Unit where + +import Control.Monad + ( forM_ ) +import Test.Hspec + ( Spec, describe, it ) +import Test.QuickCheck + ( property, (===) ) +import Text.Pretty.Simple + ( pShow ) + +import qualified Data.Text.Lazy as TL + +-------------------------------------------------------------------------------- +-- Unit test support +-------------------------------------------------------------------------------- + +data UnitTestData params result = UnitTestData + { params :: params + , result :: result + } + deriving (Eq, Show) + +unitTests + :: (Eq result, Show result) + => String + -> (params -> result) + -> [UnitTestData params result] + -> Spec +unitTests title f unitTestData = + describe title $ + forM_ (zip testNumbers unitTestData) $ + \(testNumber :: Int, test) -> do + let subtitle = "Unit test #" <> show testNumber + it subtitle $ + let resultExpected = result test in + let resultActual = f (params test) in + property $ Pretty resultExpected === Pretty resultActual + where + testNumbers :: [Int] + testNumbers = [1 ..] + +-------------------------------------------------------------------------------- +-- Pretty-printing +-------------------------------------------------------------------------------- + +-- | A combinator that causes the output of `show` to be pretty-printed. +-- +newtype Pretty a = Pretty { unPretty :: a } + deriving Eq + +instance Show a => Show (Pretty a) where + show (Pretty a) = TL.unpack ("\n" <> pShow a <> "\n") diff --git a/src/test/Test/QuickCheck/Classes/Hspec.hs b/src/test/Test/QuickCheck/Classes/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/Classes/Hspec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- Provides testing functions to check that type class instances obey laws. +-- +module Test.QuickCheck.Classes.Hspec + ( testLaws + , testLawsMany + ) where + +import Prelude + +import Control.Monad + ( forM_ ) +import Data.Proxy + ( Proxy (..) ) +import Data.Typeable + ( Typeable, typeRep ) +import Test.Hspec + ( Spec, describe, it, parallel ) +import Test.QuickCheck.Classes + ( Laws (..) ) + +-- | Constructs a test to check that the given type class instance obeys the +-- given set of laws. +-- +-- Example usage: +-- +-- >>> testLaws @Natural ordLaws +-- >>> testLaws @(Map Int) functorLaws +-- +testLaws + :: forall a. Typeable a + => (Proxy a -> Laws) + -> Spec +testLaws getLaws = + parallel $ describe description $ + forM_ (lawsProperties laws) $ uncurry it + where + description = mconcat + [ "Testing " + , lawsTypeclass laws + , " laws for type " + , show (typeRep $ Proxy @a) + ] + laws = getLaws $ Proxy @a + +-- | Calls `testLaws` with multiple sets of laws. +-- +-- Example usage: +-- +-- >>> testLawsMany @Natural [eqLaws, ordLaws] +-- >>> testLawsMany @(Map Int) [foldableLaws, functorLaws] +-- +testLawsMany + :: forall a. Typeable a + => [Proxy a -> Laws] + -> Spec +testLawsMany getLawsMany = + testLaws @a `mapM_` getLawsMany diff --git a/src/test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs b/src/test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.QuickCheck.Quid.Combinators.PrefixSpec + where + +import Internal.Test.QuickCheck.Quid.Combinators.Prefix + ( Prefix (..) ) +import Test.Hspec + ( Spec, describe, parallel ) +import Test.QuickCheck + ( Arbitrary (..), shrinkMapBy ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) + +import qualified Test.QuickCheck.Classes as Laws + +spec :: Spec +spec = do + + parallel $ describe "Lawfulness of type class instances" $ do + testLawsMany @(Prefix "A" Int) + [ Laws.showLaws + , Laws.showReadLaws + ] + testLawsMany @(Prefix ":" Int) + [ Laws.showLaws + , Laws.showReadLaws + ] + testLawsMany @(Prefix "1" Int) + [ Laws.showLaws + , Laws.showReadLaws + ] + testLawsMany @(Prefix "test-prefix:" Int) + [ Laws.showLaws + , Laws.showReadLaws + ] + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (Prefix p a) where + arbitrary = Prefix <$> arbitrary + shrink = shrinkMapBy Prefix unPrefix shrink diff --git a/src/test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs b/src/test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.QuickCheck.Quid.Representations.DecimalSpec + where + +import Internal.Test.QuickCheck.Quid + ( Quid, naturalToQuid ) +import Internal.Test.QuickCheck.Quid.Representations.Decimal + ( Decimal (..) ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe, parallel ) +import Test.Hspec.Unit + ( UnitTestData (..), unitTests ) +import Test.QuickCheck + ( Arbitrary (..) ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) + +import Prelude hiding + ( (^) ) + +import qualified Prelude +import qualified Test.QuickCheck.Classes as Laws + +spec :: Spec +spec = do + + parallel $ describe "Lawfulness of type class instances" $ do + testLawsMany @(Decimal Quid) + [ Laws.showLaws + , Laws.showReadLaws + ] + + parallel $ describe "Unit tests" $ do + unitTests_show_decimal_naturalToQuid + +-------------------------------------------------------------------------------- +-- Unit tests +-------------------------------------------------------------------------------- + +unitTests_show_decimal_naturalToQuid :: Spec +unitTests_show_decimal_naturalToQuid = unitTests + "unitTests_show_decimal_naturalToQuid" + (show . Decimal . naturalToQuid) + (mkTest <$> tests) + where + mkTest :: (Natural, String) -> UnitTestData Natural String + mkTest (params, result) = UnitTestData {params, result} + + (^) :: Natural -> Natural -> Natural + (^) = (Prelude.^) + + tests = + [ (0, "0") + , (1, "1") + , (8, "8") + , (9, "9") + + , (10^0, "1") + , (10^1, "10") + , (10^2, "100") + , (10^3, "1000") + , (10^4, "10000") + , (10^5, "100000") + , (10^6, "1000000") + , (10^7, "10000000") + + , (10^0 - 1, "0") + , (10^1 - 1, "9") + , (10^2 - 1, "99") + , (10^3 - 1, "999") + , (10^4 - 1, "9999") + , (10^5 - 1, "99999") + , (10^6 - 1, "999999") + , (10^7 - 1, "9999999") + ] + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +deriving via Quid instance Arbitrary (Decimal Quid) diff --git a/src/test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs b/src/test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.QuickCheck.Quid.Representations.HexadecimalSpec + where + +import Internal.Test.QuickCheck.Quid + ( Quid, naturalToQuid ) +import Internal.Test.QuickCheck.Quid.Representations.Hexadecimal + ( Hexadecimal (..) ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe, parallel ) +import Test.Hspec.Unit + ( UnitTestData (..), unitTests ) +import Test.QuickCheck + ( Arbitrary (..) ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) + +import Prelude hiding + ( (^) ) + +import qualified Prelude +import qualified Test.QuickCheck.Classes as Laws + +spec :: Spec +spec = do + + parallel $ describe "Lawfulness of type class instances" $ do + testLawsMany @(Hexadecimal Quid) + [ Laws.showLaws + , Laws.showReadLaws + ] + + parallel $ describe "Unit tests" $ do + unitTests_show_hexadecimal_naturalToQuid + +-------------------------------------------------------------------------------- +-- Unit tests +-------------------------------------------------------------------------------- + +unitTests_show_hexadecimal_naturalToQuid :: Spec +unitTests_show_hexadecimal_naturalToQuid = unitTests + "unitTests_show_hexadecimal_naturalToQuid" + (show . Hexadecimal . naturalToQuid) + (mkTest <$> tests) + where + mkTest :: (Natural, String) -> UnitTestData Natural String + mkTest (params, result) = UnitTestData {params, result} + + (^) :: Natural -> Natural -> Natural + (^) = (Prelude.^) + + tests = + [ ( 0, "0x0") + , ( 1, "0x1") + , (14, "0xe") + , (15, "0xf") + + , (16 + 0, "0x10") + , (16 + 1, "0x11") + , (16 + 14, "0x1e") + , (16 + 15, "0x1f") + + , (2 * 16 + 0, "0x20") + , (2 * 16 + 1, "0x21") + , (2 * 16 + 14, "0x2e") + , (2 * 16 + 15, "0x2f") + + , (15 * 16 + 0, "0xf0") + , (15 * 16 + 1, "0xf1") + , (15 * 16 + 14, "0xfe") + , (15 * 16 + 15, "0xff") + + , (16^0, "0x1") + , (16^1, "0x10") + , (16^2, "0x100") + , (16^3, "0x1000") + , (16^4, "0x10000") + , (16^5, "0x100000") + , (16^6, "0x1000000") + , (16^7, "0x10000000") + + , (16^0 - 1, "0x0") + , (16^1 - 1, "0xf") + , (16^2 - 1, "0xff") + , (16^3 - 1, "0xfff") + , (16^4 - 1, "0xffff") + , (16^5 - 1, "0xfffff") + , (16^6 - 1, "0xffffff") + , (16^7 - 1, "0xfffffff") + ] + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +deriving via Quid instance Arbitrary (Hexadecimal Quid) diff --git a/src/test/Test/QuickCheck/Quid/Representations/LatinSpec.hs b/src/test/Test/QuickCheck/Quid/Representations/LatinSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/Quid/Representations/LatinSpec.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.QuickCheck.Quid.Representations.LatinSpec + where + +import Data.Function + ( (&) ) +import Data.List + ( uncons ) +import Internal.Test.QuickCheck.Quid + ( Quid, arbitraryQuid, naturalToQuid, shrinkQuid ) +import Internal.Test.QuickCheck.Quid.Representations.Latin + ( Latin (..) + , LatinChar (..) + , LatinString + , charToLatinChar + , latinCharToChar + ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe, it, parallel ) +import Test.Hspec.Unit + ( UnitTestData (..), unitTests ) +import Test.QuickCheck + ( Arbitrary (..), Property, property, shrinkMapBy, (===) ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) + +import Prelude hiding + ( (^) ) + +import qualified Prelude +import qualified Test.QuickCheck.Classes as Laws + +spec :: Spec +spec = do + + parallel $ describe "Lawfulness of type class instances" $ do + testLawsMany @(Latin Quid) + [ Laws.showLaws + , Laws.showReadLaws + ] + + parallel $ describe "Properties" $ do + it "prop_latinCharToChar_uncons_show" $ + prop_latinCharToChar_uncons_show + & property + it "prop_roundTrip_LatinChar_Char" $ + prop_roundTrip_LatinChar_Char + & property + it "prop_roundTrip_LatinString_Quid" $ + prop_roundTrip_LatinString_Quid + & property + + parallel $ describe "Unit tests" $ do + unitTests_show_latin_naturalToQuid + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +prop_latinCharToChar_uncons_show :: LatinChar -> Property +prop_latinCharToChar_uncons_show c = + Just (latinCharToChar c) === fmap fst (uncons (show c)) + +prop_roundTrip_LatinChar_Char :: LatinChar -> Property +prop_roundTrip_LatinChar_Char c = + charToLatinChar (latinCharToChar c) === Just c + +prop_roundTrip_LatinString_Quid :: LatinString -> Property +prop_roundTrip_LatinString_Quid latinString = + show (read @(Latin Quid) expectedOutput) === expectedOutput + where + expectedOutput :: String + expectedOutput = show latinString + +-------------------------------------------------------------------------------- +-- Unit tests +-------------------------------------------------------------------------------- + +unitTests_show_latin_naturalToQuid :: Spec +unitTests_show_latin_naturalToQuid = unitTests + "unitTests_show_latin_naturalToQuid" + (show . Latin . naturalToQuid) + (mkTest <$> tests) + where + mkTest :: (Natural, String) -> UnitTestData Natural String + mkTest (params, result) = UnitTestData {params, result = show result} + + (^) :: Natural -> Natural -> Natural + (^) = (Prelude.^) + + tests = + [ ( 0, "A") + , ( 1, "B") + , (24, "Y") + , (25, "Z") + + , (26 + 0, "AA") + , (26 + 1, "AB") + , (26 + 24, "AY") + , (26 + 25, "AZ") + + , (2 * 26 + 0, "BA") + , (2 * 26 + 1, "BB") + , (2 * 26 + 24, "BY") + , (2 * 26 + 25, "BZ") + + , (26 * 26 + 0, "ZA") + , (26 * 26 + 1, "ZB") + , (26 * 26 + 24, "ZY") + , (26 * 26 + 25, "ZZ") + + , (26 , "AA") + , (26 + 26^2 , "AAA") + , (26 + 26^2 + 26^3 , "AAAA") + , (26 + 26^2 + 26^3 + 26^4 , "AAAAA") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 , "AAAAAA") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 , "AAAAAAA") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7, "AAAAAAAA") + + , (26 - 1, "Z") + , (26 + 26^2 - 1, "ZZ") + , (26 + 26^2 + 26^3 - 1, "ZZZ") + , (26 + 26^2 + 26^3 + 26^4 - 1, "ZZZZ") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 - 1, "ZZZZZ") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 - 1, "ZZZZZZ") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7 - 1, "ZZZZZZZ") + , (26 + 26^2 + 26^3 + 26^4 + 26^5 + 26^6 + 26^7 + 26^8 - 1, "ZZZZZZZZ") + ] + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance Arbitrary (Latin Quid) where + arbitrary = Latin <$> arbitraryQuid + shrink = shrinkMapBy Latin unLatin shrinkQuid diff --git a/src/test/Test/QuickCheck/QuidSpec.hs b/src/test/Test/QuickCheck/QuidSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Test/QuickCheck/QuidSpec.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.QuickCheck.QuidSpec + where + +import Control.Arrow + ( (&&&) ) +import Control.Monad + ( replicateM ) +import Data.Functor + ( (<&>) ) +import Data.Maybe + ( fromMaybe ) +import Data.Numbers.Primes + ( primes ) +import Data.Ord + ( Down (..) ) +import Data.Set + ( Set ) +import Data.Text.Lazy.Builder + ( Builder, fromLazyText ) +import Fmt + ( Buildable (..), indentF, padLeftF, pretty, (+|), (|+) ) +import Internal.Test.QuickCheck.Quid + ( Quid + , arbitraryQuid + , chooseNatural + , naturalToQuid + , quidToNatural + , shrinkNatural + ) +import Internal.Test.QuickCheck.Quid.Combinators.Size + ( Size (..) ) +import Internal.Test.QuickCheck.Quid.Representations.Decimal + ( Decimal (..) ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe, it, parallel ) +import Test.QuickCheck + ( Arbitrary (..) + , Fixed (..) + , Gen + , Property + , Testable (..) + , checkCoverage + , conjoin + , counterexample + , cover + , forAllBlind + , label + , liftShrink2 + , oneof + , property + , resize + , shrinkMapBy + , withMaxSuccess + , (.&&.) + , (===) + ) +import Test.QuickCheck.Classes.Hspec + ( testLawsMany ) +import Text.Pretty.Simple + ( pShow ) + +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Test.QuickCheck.Classes as Laws + +spec :: Spec +spec = do + + parallel $ describe "Lawfulness of type class instances" $ do + testLawsMany @TestQuid + [ Laws.eqLaws + , Laws.ordLaws + ] + testLawsMany @TestQuid + [ Laws.eqLaws + , Laws.ordLaws + , Laws.showLaws + , Laws.showReadLaws + ] + + parallel $ describe "Uniformity" $ do + it "prop_arbitraryQuid_uniform" $ + property prop_arbitraryQuid_uniform + + parallel $ describe "Uniqueness" $ do + it "prop_arbitraryQuid_unique" $ + property prop_arbitraryQuid_unique + + parallel $ describe "Shrinkability" $ do + it "prop_shrinkQuid_lessThan" $ + property prop_shrinkQuid_lessThan + it "prop_shrinkQuid_minimalElement" $ + property prop_shrinkQuid_minimalElement + it "prop_shrinkQuid_minimalSet" $ + property prop_shrinkQuid_minimalSet + it "prop_shrinkQuid_ordered" $ + property prop_shrinkQuid_ordered + it "prop_shrinkQuid_unique" $ + property prop_shrinkQuid_unique + +-------------------------------------------------------------------------------- +-- Powers of two +-------------------------------------------------------------------------------- + +newtype PowerOfTwo = PowerOfTwo {powerOfTwoExponent :: Natural} + deriving (Eq, Ord, Show) + +instance Buildable PowerOfTwo where + build (PowerOfTwo e) = "2^" <> build (show e) + +evalPowerOfTwo :: PowerOfTwo -> Natural +evalPowerOfTwo = (2 ^) . powerOfTwoExponent + +genPowerOfTwo :: (Natural, Natural) -> Gen PowerOfTwo +genPowerOfTwo (lo, hi) = PowerOfTwo <$> chooseNatural (lo, hi) + +shrinkPowerOfTwo :: PowerOfTwo -> [PowerOfTwo] +shrinkPowerOfTwo = shrinkMapBy PowerOfTwo powerOfTwoExponent shrinkNatural + +-------------------------------------------------------------------------------- +-- Prime numbers +-------------------------------------------------------------------------------- + +newtype PrimeNumber = PrimeNumber {primeNumberIndex :: Natural} + deriving (Eq, Ord, Show) + +instance Buildable PrimeNumber where + build = build . show . evalPrimeNumber + +evalPrimeNumber :: PrimeNumber -> Natural +evalPrimeNumber = indexToPrime primes . primeNumberIndex + where + indexToPrime (p : ps) i + | i == 0 = p + | otherwise = indexToPrime ps (i - 1) + indexToPrime [] _ = + error "evalPrimeNumber: Unexpected empty list of prime numbers." + +genPrimeNumber :: (Natural, Natural) -> Gen PrimeNumber +genPrimeNumber (lo, hi) = PrimeNumber <$> chooseNatural (lo, hi) + +shrinkPrimeNumber :: PrimeNumber -> [PrimeNumber] +shrinkPrimeNumber = shrinkMapBy PrimeNumber primeNumberIndex shrinkNatural + +-------------------------------------------------------------------------------- +-- Partition functions +-------------------------------------------------------------------------------- + +data PartitionFunction + = Div PowerOfTwo + | Mod PrimeNumber + deriving (Eq, Ord, Show) + +instance Buildable PartitionFunction where + build = \case + Div p -> "div " <> padLeftF 5 ' ' p + Mod p -> "mod " <> padLeftF 5 ' ' p + +evalPartitionFunction :: PartitionFunction -> (Natural -> Natural) +evalPartitionFunction = \case + Div p -> (`div` evalPowerOfTwo p) + Mod p -> (`mod` evalPrimeNumber p) + +-------------------------------------------------------------------------------- +-- Partition contexts +-------------------------------------------------------------------------------- + +data PartitionContext = PartitionContext + { sizeExponent :: PowerOfTwo + , expectedBucketCount :: Natural + , partitionFunction :: PartitionFunction + } + deriving (Eq, Ord, Show) + +instance Buildable PartitionContext where + build c = mconcat + [ "(size = " + , padLeftF 5 ' ' (sizeExponent c) + , ", expected bucket count = " + , padLeftF 3 ' ' (show $ expectedBucketCount c) + , ", partition function = " + , build (partitionFunction c) + , ")" + ] + +-------------------------------------------------------------------------------- +-- Div partitions +-------------------------------------------------------------------------------- + +data DivPartition = DivPartition + { divArgument :: PowerOfTwo + , scaleFactor :: PowerOfTwo + } + deriving (Eq, Ord, Show) + +evalDivPartition :: DivPartition -> PartitionContext +evalDivPartition DivPartition {divArgument, scaleFactor} = + PartitionContext + { sizeExponent = PowerOfTwo + $ powerOfTwoExponent divArgument + + powerOfTwoExponent scaleFactor + , expectedBucketCount = evalPowerOfTwo scaleFactor + , partitionFunction = Div divArgument + } + +genDivPartition :: Gen DivPartition +genDivPartition = do + divArgument <- oneof (genPowerOfTwo <$> [(0, 1), (2, 256)]) + scaleFactor <- oneof (genPowerOfTwo <$> [(0, 1), (2, 8)]) + pure DivPartition {divArgument, scaleFactor} + +shrinkDivPartition :: DivPartition -> [DivPartition] +shrinkDivPartition = shrinkMapBy unTuple toTuple $ + liftShrink2 shrinkPowerOfTwo shrinkPowerOfTwo + where + unTuple (c, s) = (DivPartition c s) + toTuple (DivPartition c s) = (c, s) + +-------------------------------------------------------------------------------- +-- Mod partitions +-------------------------------------------------------------------------------- + +data ModPartition = ModPartition + { modArgument :: PrimeNumber + , scaleFactor :: PowerOfTwo + } + deriving (Eq, Ord, Show) + +evalModPartition :: ModPartition -> PartitionContext +evalModPartition ModPartition {modArgument, scaleFactor} = + PartitionContext + { sizeExponent = PowerOfTwo + $ primeNumberIndex modArgument + + powerOfTwoExponent scaleFactor + + 8 + , expectedBucketCount = evalPrimeNumber modArgument + , partitionFunction = Mod modArgument + } + +genModPartition :: Gen ModPartition +genModPartition = do + modArgument <- oneof (genPrimeNumber <$> [(0, 1), (2, 32)]) + scaleFactor <- oneof (genPowerOfTwo <$> [(0, 1), (2, 256)]) + pure ModPartition {modArgument, scaleFactor} + +shrinkModPartition :: ModPartition -> [ModPartition] +shrinkModPartition = shrinkMapBy unTuple toTuple $ + liftShrink2 shrinkPrimeNumber shrinkPowerOfTwo + where + unTuple (m, s) = (ModPartition m s) + toTuple (ModPartition m s) = (m, s) + +-------------------------------------------------------------------------------- +-- Partitions +-------------------------------------------------------------------------------- + +data Partition + = DivPartitionOf DivPartition + | ModPartitionOf ModPartition + deriving (Eq, Ord, Show) + +instance Arbitrary Partition where + arbitrary = genPartition + shrink = shrinkPartition + +evalPartition :: Partition -> PartitionContext +evalPartition = \case + DivPartitionOf p -> evalDivPartition p + ModPartitionOf p -> evalModPartition p + +genPartition :: Gen Partition +genPartition = oneof + [ DivPartitionOf <$> genDivPartition + , ModPartitionOf <$> genModPartition + ] + +shrinkPartition :: Partition -> [Partition] +shrinkPartition = \case + DivPartitionOf p -> DivPartitionOf <$> shrinkDivPartition p + ModPartitionOf p -> ModPartitionOf <$> shrinkModPartition p + +-------------------------------------------------------------------------------- +-- Uniformity +-------------------------------------------------------------------------------- + +prop_arbitraryQuid_uniform :: Partition -> Property +prop_arbitraryQuid_uniform p = + label (pretty partitionContext) $ + forAllBlind arbitraryValues prop + where + partitionContext :: PartitionContext + partitionContext@PartitionContext + { sizeExponent + , expectedBucketCount + , partitionFunction + } = evalPartition p + + valueToBucket :: Quid -> Natural + valueToBucket = (evalPartitionFunction partitionFunction) . quidToNatural + + arbitraryValue :: Gen Quid + arbitraryValue = + resize (fromIntegral (powerOfTwoExponent sizeExponent)) arbitraryQuid + + arbitraryValues :: Gen [Quid] + arbitraryValues = + replicateM (fromIntegral arbitraryValueCount) arbitraryValue + + arbitraryValueCount :: Natural + arbitraryValueCount = unFrequency expectedFrequency * expectedBucketCount + + expectedFrequency :: Frequency + expectedFrequency = Frequency 1024 + + minimumPermittedFrequency :: Frequency + minimumPermittedFrequency = expectedFrequency <&> ((* 3) . (`div` 4)) + + maximumPermittedFrequency :: Frequency + maximumPermittedFrequency = expectedFrequency <&> ((* 5) . (`div` 4)) + + prop :: [Quid] -> Property + prop values = reports $ checks $ property True + where + reports + = report sizeExponent + "size exponent" + . report arbitraryValueCount + "arbitrary value count" + . report expectedBucketCount + "expected bucket count" + . report occupiedBucketCount + "occupied bucket count" + . report expectedFrequency + "expected frequency" + . report minimumObservedFrequency + "minimum observed frequency" + . report minimumPermittedFrequency + "minimum permitted frequency" + . report maximumObservedFrequency + "maximum observed frequency" + . report maximumPermittedFrequency + "maximum permitted frequency" + checks + = check + (occupiedBucketCount == expectedBucketCount) + "occupiedBucketCount == expectedBucketCount" + . check + (minimumObservedFrequency >= minimumPermittedFrequency) + "minimumObservedFrequency >= minimumPermittedFrequency" + . check + (maximumObservedFrequency <= maximumPermittedFrequency) + "maximumObservedFrequency <= maximumPermittedFrequency" + + occupiedBuckets :: [Natural] + occupiedBuckets = valueToBucket <$> values + + occupiedBucketFrequencies :: [(Natural, Frequency)] + occupiedBucketFrequencies = frequencies occupiedBuckets + + occupiedBucketCount :: Natural + occupiedBucketCount = fromIntegral $ length occupiedBucketFrequencies + + minimumObservedFrequency :: Frequency + minimumObservedFrequency = + snd $ lastNote note occupiedBucketFrequencies + where + note = "minimumObservedFrequency: unexpected empty list" + + maximumObservedFrequency :: Frequency + maximumObservedFrequency = + snd $ headNote note occupiedBucketFrequencies + where + note = "maximumObservedFrequency: unexpected empty list" + +-------------------------------------------------------------------------------- +-- Uniqueness +-------------------------------------------------------------------------------- + +prop_arbitraryQuid_unique :: Property +prop_arbitraryQuid_unique = + withMaxSuccess 1 $ + forAllBlind arbitraryFixedSizeQuids $ \uids -> + Set.size (Set.fromList uids) === L.length uids + where + arbitraryFixedSizeQuids :: Gen [TestQuid] + arbitraryFixedSizeQuids = fmap (unSize . getFixed) <$> + replicateM 1_000_000 (arbitrary @(Fixed (Size 256 TestQuid))) + +-------------------------------------------------------------------------------- +-- Shrinkability +-------------------------------------------------------------------------------- + +prop_shrinkQuid_lessThan :: Size 256 TestQuid -> Property +prop_shrinkQuid_lessThan (Size q) = + property $ all (< q) (shrink q) + +prop_shrinkQuid_minimalElement :: TestQuid -> Property +prop_shrinkQuid_minimalElement q = + checkCoverage $ + cover 10 (q /= minimalQuid) "q /= minimalQuid" $ + case shrink q of + s : _ -> s === minimalQuid + _ -> q === minimalQuid + where + minimalQuid = TestQuid 0 + +prop_shrinkQuid_minimalSet :: [Size 256 TestQuid] -> Property +prop_shrinkQuid_minimalSet qs = + label (show $ bucket expectedSize) $ + counterexample (show expectedSize) $ + counterexample (show minimalSet) $ + conjoin + [ Set.toList minimalSet `L.isPrefixOf` allQuids + , Set.size minimalSet == expectedSize + ] + where + allQuids :: [TestQuid] + allQuids = TestQuid . naturalToQuid <$> [0 ..] + + bucket :: Int -> (Int, Int) + bucket size = (lo, hi) + where + lo = size `div` 10 * 10 + hi = lo + 9 + + expectedSize :: Int + expectedSize = L.length qs + + minimalSet :: Set TestQuid + minimalSet = Set.map unSize $ fromMaybe + (error "Cannot shrink to minimal set") + (shrinkWhile ((>= expectedSize) . Set.size) shrink (Set.fromList qs)) + +prop_shrinkQuid_ordered :: Size 256 TestQuid -> Property +prop_shrinkQuid_ordered (Size q) = + L.sort shrunkValues === shrunkValues + where + shrunkValues = shrink q + +prop_shrinkQuid_unique :: Size 256 TestQuid -> Property +prop_shrinkQuid_unique (Size q) = + Set.size (Set.fromList shrunkValues) === L.length shrunkValues + where + shrunkValues = shrink q + +-------------------------------------------------------------------------------- +-- Shrinking +-------------------------------------------------------------------------------- + +shrinkWhile :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a +shrinkWhile condition shrinkFn = loop + where + loop a + | condition a = + case L.find condition (shrinkFn a) of + Nothing -> Just a + Just a' -> loop a' + | otherwise = + Nothing + +-------------------------------------------------------------------------------- +-- Frequencies +-------------------------------------------------------------------------------- + +type Frequency = FrequencyOf Natural + +newtype FrequencyOf a = Frequency {unFrequency :: a} + deriving (Eq, Functor, Ord, Show) + +instance Semigroup Frequency where + Frequency f1 <> Frequency f2 = Frequency (f1 + f2) + +instance Monoid Frequency where + mempty = Frequency 1 + +frequencies :: (Foldable f, Ord k) => f k -> [(k, Frequency)] +frequencies + = L.sortOn ((Down . snd) &&& fst) + . Map.toList + . L.foldr (flip (Map.insertWith (<>)) mempty) Map.empty + +-------------------------------------------------------------------------------- +-- Reporting +-------------------------------------------------------------------------------- + +-- | Adds a named variable to the counterexample output of a property. +-- +-- On failure, uses pretty-printing to show the contents of the variable. +-- +report :: (Show a, Testable prop) => a -> String -> prop -> Property +report a name = counterexample $ + "" +| name |+ ":\n" +| indentF 4 (pShowBuilder a) |+ "" + where + pShowBuilder :: Show a => a -> Builder + pShowBuilder = fromLazyText . pShow + +-------------------------------------------------------------------------------- +-- Verification +-------------------------------------------------------------------------------- + +-- | Adds a named condition to a property. +-- +-- On failure, reports the name of the condition that failed. +-- +check :: Bool -> String -> Property -> Property +check condition conditionTitle = + (.&&.) (counterexample counterexampleText $ property condition) + where + counterexampleText = "Condition violated: " <> conditionTitle + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +headNote :: String -> [a] -> a +headNote note = g + where + g [] = error note + g (a : _) = a + +lastNote :: String -> [a] -> a +lastNote note = g + where + g [] = error note + g [a] = a + g (_ : as) = g as + +-------------------------------------------------------------------------------- +-- Test types +-------------------------------------------------------------------------------- + +newtype TestQuid = TestQuid Quid + deriving (Read, Show) via (Decimal Quid) + deriving Arbitrary via Quid + deriving stock (Eq, Ord)