packages feed

quickcheck-quid (empty) → 0.0.1

raw patch · 23 files changed

+1965/−0 lines, 23 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, deepseq, extra, fmt, hashable, hspec, pretty-simple, primes, quickcheck-classes, quickcheck-quid, text

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+Quasi-unique identifiers for QuickCheck.++![Build Status](https://github.com/jonathanknowles/quickcheck-quid/actions/workflows/haskell.yml/badge.svg)
+ quickcheck-quid.cabal view
@@ -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
+ src/quickcheck-quid-example/Test/QuickCheck/Quid/Example.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Chunk.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Prefix.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Combinators/Size.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Decimal.hs view
@@ -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 ""
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Hexadecimal.hs view
@@ -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 ""
+ src/quickcheck-quid-internal/Internal/Test/QuickCheck/Quid/Representations/Latin.hs view
@@ -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
+ src/quickcheck-quid-internal/Internal/Text/Read.hs view
@@ -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
+ src/quickcheck-quid-test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/quickcheck-quid-test/Test/Hspec/Unit.hs view
@@ -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")
+ src/quickcheck-quid-test/Test/QuickCheck/Classes/Hspec.hs view
@@ -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
+ src/quickcheck-quid-test/Test/QuickCheck/Quid/Combinators/PrefixSpec.hs view
@@ -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
+ src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/DecimalSpec.hs view
@@ -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)
+ src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/HexadecimalSpec.hs view
@@ -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)
+ src/quickcheck-quid-test/Test/QuickCheck/Quid/Representations/LatinSpec.hs view
@@ -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
+ src/quickcheck-quid-test/Test/QuickCheck/QuidSpec.hs view
@@ -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)
+ src/quickcheck-quid/Test/QuickCheck/Quid.hs view
@@ -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 (..) )