diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2022 Jonathan Knowles + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +Quasi-unique identifiers for QuickCheck. + +![Build Status](https://github.com/jonathanknowles/quickcheck-quid/actions/workflows/haskell.yml/badge.svg) diff --git a/quickcheck-quid.cabal b/quickcheck-quid.cabal new file mode 100644 --- /dev/null +++ b/quickcheck-quid.cabal @@ -0,0 +1,103 @@ +cabal-version: 3.0 +name: quickcheck-quid +version: 0.0.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 +category: Testing +synopsis: Quasi-unique identifiers for QuickCheck +description: + Quasi-unique identifiers for QuickCheck. + + For the most up-to-date documentation, please view the following page: + + https://github.com/jonathanknowles/quickcheck-quid/blob/main/README.md + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/jonathanknowles/quickcheck-quid + +library + hs-source-dirs: + src/quickcheck-quid + exposed-modules: + Test.QuickCheck.Quid + default-language: + Haskell2010 + build-depends: + base >=4.7 && <5 + , quickcheck-quid-internal + +library quickcheck-quid-example + hs-source-dirs: + src/quickcheck-quid-example + exposed-modules: + Test.QuickCheck.Quid.Example + default-language: + Haskell2010 + build-depends: + QuickCheck + , base >=4.7 && <5 + , quickcheck-quid + +library quickcheck-quid-internal + hs-source-dirs: + src/quickcheck-quid-internal + exposed-modules: + Internal.Test.QuickCheck + Internal.Test.QuickCheck.Quid + Internal.Test.QuickCheck.Quid.Combinators.Chunk + Internal.Test.QuickCheck.Quid.Combinators.Prefix + Internal.Test.QuickCheck.Quid.Combinators.Size + Internal.Test.QuickCheck.Quid.Representations + Internal.Test.QuickCheck.Quid.Representations.Decimal + Internal.Test.QuickCheck.Quid.Representations.Hexadecimal + Internal.Test.QuickCheck.Quid.Representations.Latin + Internal.Text.Read + default-language: + Haskell2010 + build-depends: + QuickCheck + , base >=4.7 && <5 + , containers + , deepseq + , extra + , hashable + , text + +test-suite quickcheck-quid-test + main-is: + Spec.hs + hs-source-dirs: + src/quickcheck-quid-test + other-modules: + Test.QuickCheck.Classes.Hspec + Test.QuickCheck.QuidSpec + Test.QuickCheck.Quid.Combinators.PrefixSpec + Test.QuickCheck.Quid.Representations.DecimalSpec + Test.QuickCheck.Quid.Representations.HexadecimalSpec + Test.QuickCheck.Quid.Representations.LatinSpec + Test.Hspec.Unit + type: exitcode-stdio-1.0 + default-language: + Haskell2010 + 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 diff --git a/src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs b/src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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 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 new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs @@ -0,0 +1,162 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Spec.hs b/src/quickcheck-quid-test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-test/Spec.hs @@ -0,0 +1,1 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-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/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs @@ -0,0 +1,121 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid-test/Test/QuickCheck/QuidSpec.hs @@ -0,0 +1,525 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/quickcheck-quid/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 (..) )