Merge pull request #89 from haskellari/better-arb-uuid

Improve Arbitrary UUID instance
haskellari · Oct 4, 2023 · 11412ed · 11412ed
2 parents b56688a + 8457fc2
commit 11412ed
Show file tree

Hide file tree

Showing 5 changed files with 39 additions and 11 deletions.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -297,10 +297,10 @@ jobs:
           if [ $((HCNUMVER < 90400)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='text ^>=1.2.3.0' all ; fi
       - name: constraint set lower-bounds-7.4.2
         run: |
-          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.3' --constraint='vector                 ==0.12.3.1' all --dry-run ; fi
+          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.4' --constraint='vector                 ==0.12.3.1' all --dry-run ; fi
           if [ $((HCNUMVER < 70600)) -ne 0 ] ; then cabal-plan topo | sort ; fi
-          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.3' --constraint='vector                 ==0.12.3.1' --dependencies-only -j2 all ; fi
-          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.3' --constraint='vector                 ==0.12.3.1' all ; fi
+          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.4' --constraint='vector                 ==0.12.3.1' --dependencies-only -j2 all ; fi
+          if [ $((HCNUMVER < 70600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='QuickCheck             ==2.14.1' --constraint='array                  ==0.4.0.0' --constraint='base                   ==4.5.1.0' --constraint='base-compat            ==0.10.5' --constraint='bytestring             ==0.9.2.1' --constraint='case-insensitive       ==1.2.0.4' --constraint='containers             ==0.4.2.1' --constraint='hashable               ==1.2.7.0' --constraint='nats                   ==1.1.2' --constraint='old-time               ==1.1.0.0' --constraint='scientific             ==0.3.6.2' --constraint='semigroups             ==0.18.5' --constraint='tagged                 ==0.8.6' --constraint='text                   ==1.2.3.0' --constraint='these                  ==1.1.1.1' --constraint='time                   ==1.2.0.1' --constraint='transformers           ==0.3.0.0' --constraint='transformers-compat    ==0.6.5' --constraint='unordered-containers   ==0.2.2.0' --constraint='uuid-types             ==1.0.4' --constraint='vector                 ==0.12.3.1' all ; fi
       - name: save cache
         uses: actions/cache/save@v3
         if: always()

diff --git a/CHANGES b/CHANGES
@@ -1,3 +1,27 @@
+0.3.30
+
+* Improve Arbitrary UUID instance
+
+  Previously "small" UUIDs were generated, e.g.
+
+  ```
+  00000001-0000-0001-0000-000000000001
+  00000002-0000-0000-0000-000200000002
+  00000004-0000-0004-0000-000400000001
+  00000005-0000-0000-0000-000500000007
+  00000001-0000-000d-0000-00050000000e
+  ```
+
+  but now they are uniformly random
+
+  ```
+  c4683284-bfe3-224b-29a6-1e7f11ceef65
+  7bf6564d-5dcf-3e37-b13d-867085f54dae
+  5b006243-0a70-9321-6594-20dde3d72112
+  2d8ed56e-ed20-7258-7c1f-b46fa9b87946
+  f1503184-9d3c-aacd-e9a7-36c655b70f41
+  ```
+
 0.3.29.1
 
 * Support `OneTuple-0.4`

diff --git a/cabal.haskell-ci b/cabal.haskell-ci
@@ -26,7 +26,7 @@ constraint-set lower-bounds-7.4.2
     transformers           ==0.3.0.0,
     transformers-compat    ==0.6.5,
     unordered-containers   ==0.2.2.0,
-    uuid-types             ==1.0.3,
+    uuid-types             ==1.0.4,
     vector                 ==0.12.3.1
 
 constraint-set text-1.2

diff --git a/quickcheck-instances.cabal b/quickcheck-instances.cabal
@@ -107,7 +107,7 @@ library
     , transformers          >=0.3.0.0  && <0.7
     , transformers-compat   >=0.6.5    && <0.8
     , unordered-containers  >=0.2.2.0  && <0.3
-    , uuid-types            >=1.0.3    && <1.1
+    , uuid-types            >=1.0.4    && <1.1
     , vector                >=0.12.3.1 && <0.14
 
   -- version is irrelevant.

diff --git a/src/Test/QuickCheck/Instances/UUID.hs b/src/Test/QuickCheck/Instances/UUID.hs
@@ -6,26 +6,30 @@ module Test.QuickCheck.Instances.UUID () where
 import Prelude ()
 import Test.QuickCheck.Instances.CustomPrelude
 
-import Data.Word (Word32)
+import Data.Word (Word64)
 
 import Test.QuickCheck
+import Test.QuickCheck.Gen (chooseUpTo)
 
 import qualified Data.UUID.Types as UUID
 
 -------------------------------------------------------------------------------
 -- uuid
 -------------------------------------------------------------------------------
 
-uuidFromWords :: (Word32, Word32, Word32, Word32) -> UUID.UUID
-uuidFromWords (a,b,c,d) = UUID.fromWords a b c d
+uuidFromWords64 :: (Word64, Word64) -> UUID.UUID
+uuidFromWords64 (a,b) = UUID.fromWords64 a b
+
+uniformWord64 :: Gen Word64
+uniformWord64 = chooseUpTo maxBound
 
 -- | Uniform distribution.
 instance Arbitrary UUID.UUID where
-    arbitrary = uuidFromWords <$> arbitrary
-    shrink = map uuidFromWords . shrink . UUID.toWords
+    arbitrary = UUID.fromWords64 <$> uniformWord64 <*> uniformWord64
+    shrink = map uuidFromWords64 . shrink . UUID.toWords64
 
 instance CoArbitrary UUID.UUID where
     coarbitrary = coarbitrary . UUID.toWords
 
 instance Function UUID.UUID where
-    function = functionMap UUID.toWords uuidFromWords
+    function = functionMap UUID.toWords64 uuidFromWords64