diff --git a/primer/gen/Primer/Gen/Core/Typed.hs b/primer/gen/Primer/Gen/Core/Typed.hs index 58036bebd..1020a9c60 100644 --- 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 index 378c72ea5..e7f5d7db8 100644 --- 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