test: adjust distributions to make duplicates more likely (#1053)

hackworthltd · Jun 1, 2023 · e64a289 · e64a289
2 parents f353800 + d5ef650
commit e64a289
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 8 deletions.
diff --git a/primer/gen/Primer/Gen/Core/Typed.hs b/primer/gen/Primer/Gen/Core/Typed.hs
@@ -19,6 +19,8 @@ module Primer.Gen.Core.Typed (
   genInstApp,
   genCxtExtendingGlobal,
   genCxtExtendingLocal,
+  genChar,
+  genInt,
   genPrimCon,
   genTypeDefGroup,
   forAllT,
@@ -613,11 +615,8 @@ genCxtExtendingLocal = do
 -- We have to be careful to only generate primitive constructors which are
 -- in scope (i.e. their type is in scope)
 genPrimCon :: forall mc mg. (MonadReader Cxt mc, MonadGen mg) => mc [(mg PrimCon, TyConName)]
-genPrimCon = catMaybes <$> sequence [genChar, genInt]
+genPrimCon = catMaybes <$> sequence [whenInScope PrimChar 'a' genChar, whenInScope PrimInt 0 genInt]
   where
-    genChar = whenInScope PrimChar 'a' Gen.unicode
-    intBound = fromIntegral (maxBound :: Word64) -- arbitrary
-    genInt = whenInScope PrimInt 0 $ Gen.integral $ Range.linear (-intBound) intBound
     -- The 'tst' is arbitrary, only used for checking if the primcon is in scope
     -- and does not affect the generator.
     whenInScope :: (a -> PrimCon) -> a -> mg a -> mc (Maybe (mg PrimCon, TyConName))
@@ -632,6 +631,26 @@ genPrimCon = catMaybes <$> sequence [genChar, genInt]
       PrimChar _ -> ()
       PrimInt _ -> ()
 
+-- We bias the distribution towards a small set, to make it more likely we
+-- generate name clashes on occasion
+genChar :: MonadGen mg => mg Char
+genChar =
+  Gen.choice
+    [ Gen.enum 'a' 'c'
+    , Gen.enum 'a' 'f'
+    , Gen.unicode
+    ]
+
+genInt :: MonadGen mg => mg Integer
+genInt =
+  Gen.choice
+    [ Gen.integral $ Range.linear 0 3
+    , Gen.integral $ Range.linear (-3) 3
+    , Gen.integral $ Range.linear (-intBound) intBound
+    ]
+  where
+    intBound = fromIntegral (maxBound :: Word64) -- arbitrary
+
 hoist' :: Applicative f => Cxt -> WT a -> f a
 hoist' cxt = pure . evalTestM 0 . flip runReaderT cxt . unWT
 

diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs
@@ -26,7 +26,6 @@ import Hedgehog (
  )
 import Hedgehog.Gen qualified as Gen
 import Hedgehog.Internal.Property (forAllWithT)
-import Hedgehog.Range qualified as Range
 import Optics (ix, toListOf, (%), (.~), (^..), _head)
 import Primer.Action (
   ActionError (CaseBindsClash, NameCapture),
@@ -117,7 +116,7 @@ import Primer.Def (
 import Primer.Examples (comprehensiveWellTyped)
 import Primer.Gen.App (genApp)
 import Primer.Gen.Core.Raw (genName)
-import Primer.Gen.Core.Typed (WT, forAllT, propertyWT)
+import Primer.Gen.Core.Typed (WT, forAllT, genChar, genInt, propertyWT)
 import Primer.Log (PureLog, runPureLog)
 import Primer.Module (
   Module (Module, moduleDefs),
@@ -324,8 +323,8 @@ tasty_available_actions_accepted = withTests 500 $
                     opts' <> case free of
                       Available.FreeNone -> []
                       Available.FreeVarName -> [(StudentProvided,) . flip Available.Option Nothing <$> (unName <$> genName)]
-                      Available.FreeInt -> [(StudentProvided,) . flip Available.Option Nothing <$> (show <$> Gen.integral (Range.linear @Integer 0 1_000_000_000))]
-                      Available.FreeChar -> [(StudentProvided,) . flip Available.Option Nothing . T.singleton <$> Gen.unicode]
+                      Available.FreeInt -> [(StudentProvided,) . flip Available.Option Nothing <$> (show <$> genInt)]
+                      Available.FreeChar -> [(StudentProvided,) . flip Available.Option Nothing . T.singleton <$> genChar]
               case opts'' of
                 [] -> annotate "no options" >> success
                 options -> do