clash-lib-hedgehog 1.6.6 → 1.8.0

raw patch · 10 files changed

+130/−100 lines, 10 filesdep ~clash-libdep ~mmorphdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: clash-lib, mmorph, mtl, text

API changes (from Hackage documentation)

Files

• clash-lib-hedgehog.cabal +5/−5
• src/Clash/Hedgehog/Core/DataCon.hs +7/−6
• src/Clash/Hedgehog/Core/Literal.hs +37/−1
• src/Clash/Hedgehog/Core/Name.hs +7/−6
• src/Clash/Hedgehog/Core/Term.hs +15/−14
• src/Clash/Hedgehog/Core/TyCon.hs +17/−16
• src/Clash/Hedgehog/Core/Type.hs +15/−14
• src/Clash/Hedgehog/Core/Var.hs +14/−21
• src/Clash/Hedgehog/Internal/Bias.hs +4/−0
• src/Clash/Hedgehog/Unique.hs +9/−17

@@ -1,7 +1,7 @@ cabal-version:      2.2  name:               clash-lib-hedgehog-version:            1.6.6+version:            1.8.0 synopsis:           Hedgehog Generators for clash-lib description:        Hedgehog Generators for clash-lib bug-reports:        https://github.com/clash-lang/clash-compiler/issues@@ -55,11 +55,11 @@     ghc-typelits-knownnat     >= 0.7.2   && < 0.8,     ghc-typelits-natnormalise >= 0.7.2   && < 0.8,     hedgehog-fakedata         >= 0.0.1.4 && < 0.1,-    mmorph                    >= 1.1.5   && < 1.2,-    mtl                       >= 2.1.2   && < 2.3,+    mmorph                    >= 1.1.5   && < 1.3,+    mtl                       >= 2.1.2   && < 2.4,     pretty-show               >= 1.9     && < 2.0,     primitive                 >= 0.5.0.1 && < 1.0,-    text                      >= 1.2.2   && < 1.4,+    text                      >= 1.2.2   && < 2.1,     transformers              >= 0.5.2.0 && < 0.7, -    clash-lib                 == 1.6.6,+    clash-lib                 == 1.8.0,

@@ -25,7 +25,7 @@ import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.TysPrim (liftedTypeKind)-import Clash.Unique+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Core.Monad import Clash.Hedgehog.Core.Name@@ -119,12 +119,13 @@   go :: ConTag -> DcName -> CoreGenT m DataCon   go tag name = do     let resTy = mkTyConApp tcn (fmap VarTy univTvs)-    let bound = listToUniqMap (zip univTvs univTvs)+    let bound = UniqMap.fromList (zip univTvs univTvs)     let argGen = genMonoTypeFrom tcm bound liftedTypeKind -- TODO Make polymorphic     ty <- genWithCodomain resTy argGen -    -- If there are type variables, getMonoTypeFrom is wrong.-    let ([], argTys) = partitionEithers $ fst (splitFunForallTy ty)+    let argTys = case partitionEithers $ fst (splitFunForallTy ty) of+          ([],_) -> error "getMonoTypeFrom is wrong, there are type variables"+          (_,vs) -> vs     bangs <- traverse (genStrictness tcm) argTys     fields <- replicateM (length argTys) genFieldLabel @@ -157,7 +158,7 @@   go :: ConTag -> DcName -> CoreGenT m DataCon   go tag name = do     let resTy = mkTyConApp tcn (fmap VarTy univTvs)-    let bound = listToUniqMap (zip univTvs univTvs)+    let bound = UniqMap.fromList (zip univTvs univTvs)     let argGen = genMonoTypeFrom tcm bound liftedTypeKind -- TODO Make polymorphic.     ty <- genWithCodomain resTy argGen @@ -194,7 +195,7 @@   -- Assume that any primitive type constructor is always strict. This may   -- overapproximate strictness, as it means Type, Nat and Symbol are strict.   | TyConApp tc [] <- tyView kn-  , Just PrimTyCon{} <- lookupUniqMap tc tcm+  , Just PrimTyCon{} <- UniqMap.lookup tc tcm   = pure Strict    -- Shrink towards laziness as this is the default in Haskell (assuming no

@@ -6,6 +6,8 @@ Random type-directed generation of literals. -} +{-# LANGUAGE CPP #-}+ module Clash.Hedgehog.Core.Literal   ( genLiteralFrom   ) where@@ -23,7 +25,7 @@ import Clash.Core.TysPrim  -- | Generate a 'Literal' with the specified core type. If the type does not--- correspond to a known 'PrimTyCon' (as defined in "Clash.Core.TysPrim") then+-- correspond to a known @PrimTyCon@ (as defined in @Clash.Core.TysPrim@) then -- an error is returned. -- genLiteralFrom@@ -38,6 +40,14 @@   | aeqType ty wordPrimTy = genWordLiteral   | aeqType ty int64PrimTy = genInt64Literal   | aeqType ty word64PrimTy = genWord64Literal+#if MIN_VERSION_base(4,16,0)+  | aeqType ty int8PrimTy = genInt8Literal+  | aeqType ty int16PrimTy = genInt16Literal+  | aeqType ty int32PrimTy = genInt32Literal+  | aeqType ty word8PrimTy = genWord8Literal+  | aeqType ty word16PrimTy = genWord16Literal+  | aeqType ty word32PrimTy = genWord32Literal+#endif   | aeqType ty stringPrimTy = genStringLiteral   | aeqType ty floatPrimTy = genFloatLiteral   | aeqType ty doublePrimTy = genDoubleLiteral@@ -79,6 +89,32 @@ genWord64Literal :: forall m. MonadGen m => m Literal genWord64Literal =   Word64Literal <$> (toInteger <$> Gen.word64 Range.linearBounded)++#if MIN_VERSION_base(4,16,0)+genInt8Literal :: forall m. MonadGen m => m Literal+genInt8Literal =+  Int8Literal <$> (toInteger <$> Gen.int8 Range.linearBounded)++genInt16Literal :: forall m. MonadGen m => m Literal+genInt16Literal =+  Int16Literal <$> (toInteger <$> Gen.int16 Range.linearBounded)++genInt32Literal :: forall m. MonadGen m => m Literal+genInt32Literal =+  Int32Literal <$> (toInteger <$> Gen.int32 Range.linearBounded)++genWord8Literal :: forall m. MonadGen m => m Literal+genWord8Literal =+  Word8Literal <$> (toInteger <$> Gen.word8 Range.linearBounded)++genWord16Literal :: forall m. MonadGen m => m Literal+genWord16Literal =+  Word16Literal <$> (toInteger <$> Gen.word16 Range.linearBounded)++genWord32Literal :: forall m. MonadGen m => m Literal+genWord32Literal =+  Word32Literal <$> (toInteger <$> Gen.word32 Range.linearBounded)+#endif  genStringLiteral :: forall m. MonadGen m => m Literal genStringLiteral =

@@ -30,7 +30,8 @@ import Clash.Core.TyCon (TyConName) import Clash.Core.Type (KiName, TyName) import Clash.Core.Name-import Clash.Unique (UniqSet, elemUniqSetDirectly, emptyUniqSet, extendUniqSet)+import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Unique (genUnique) @@ -70,16 +71,16 @@ genVarName = genName (genOccNameWith Text.toLower)  -- | Generate a name using the given generator, while ensuring the unique of--- the generated name does not occur in the given @UniqSet@.+-- the generated name does not occur in the given @UniqMap@. -- genFreshName   :: forall m a b    . MonadGen m-  => UniqSet b+  => UniqMap b   -> m (Name a)   -> m (Name a) genFreshName used =-  Gen.filterT (not . flip elemUniqSetDirectly used . nameUniq)+  Gen.filterT (not . flip UniqMap.elem used . nameUniq)  mapAccumLM   :: forall m acc x y@@ -106,8 +107,8 @@   -> m (Name a)   -> m [Name a] genNames n gen =-  snd <$> mapAccumLM go emptyUniqSet [1..n]+  snd <$> mapAccumLM go mempty [1..n]  where    go used _ = do     name <- genFreshName used gen-    pure (extendUniqSet used name, name)+    pure (UniqMap.insertUnique name used, name)

@@ -25,7 +25,8 @@ import Clash.Core.TysPrim (liftedTypeKind, typeSymbolKind) import Clash.Core.Util (listToLets) import Clash.Core.Var-import Clash.Unique+import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Core.Literal import Clash.Hedgehog.Core.Monad@@ -61,7 +62,7 @@     -- kinds other than Type, i.e. no type params / poly kinds. See the     -- 'genAlgTyCon' function and NOTE [finding more complex fits].     let dcs = concatMap tyConDataCons tcm-    let dcm = listToUniqMap (zip dcs dcs)+    let dcm = UniqMap.fromList (zip dcs dcs)     (dc, holes) <- sampleUniqMap (const True) hole dcm     holeFills <- traverse genSub holes @@ -87,7 +88,7 @@   sampleId <|> genOr  where   sampleId = do-    let tmEnv = mapMaybeUniqMap (either (const Nothing) Just) env+    let tmEnv = UniqMap.mapMaybe (either (const Nothing) Just) env     (i, holes) <- sampleUniqMap (const True) hole tmEnv     holeFills <- traverse genSub holes @@ -155,7 +156,7 @@     -- Hole: forall i. a     normHole@(ForAllTy i a) ->       Gen.recursive Gen.choice-        [TyLam i <$> genTermFrom tcm (extendUniqMap i (Left i) env) a]+        [TyLam i <$> genTermFrom tcm (UniqMap.insert i (Left i) env) a]         [Tick <$> genTickInfo tcm <*> genFreshTerm tcm env normHole]      AnnType _ a ->@@ -166,14 +167,14 @@         -- Hole: a -> b         FunTy a b ->           Gen.recursive Gen.choice-            [do i <- genLocalId a (genFreshName (uniqMapToUniqSet env) genVarName)-                Gen.subterm (genTermFrom tcm (extendUniqMap i (Right i) env) b) (Lam i)+            [do i <- genLocalId a (genFreshName env genVarName)+                Gen.subterm (genTermFrom tcm (UniqMap.insert i (Right i) env) b) (Lam i)             ]             [Tick <$> genTickInfo tcm <*> genFreshTerm tcm env normHole]          -- Hole: Primitive type constructor.         TyConApp tcn []-          |  Just PrimTyCon{} <- lookupUniqMap tcn tcm+          |  Just PrimTyCon{} <- UniqMap.lookup tcn tcm           -> Gen.recursive Gen.choice                [Literal <$> genLiteralFrom normHole]                -- We may fail to generate a case expression if there is nothing@@ -185,7 +186,7 @@          -- Hole: Algebraic type constructor.         TyConApp tcn _-          |  Just AlgTyCon{} <- lookupUniqMap tcn tcm+          |  Just AlgTyCon{} <- UniqMap.lookup tcn tcm           -- We may have got here by trying to fill the hole with an identifier, so           -- it makes sense to try again. If we got here by sampleDataConOr, the           -- data constructor is isomorphic to Void, and we will hit the error.@@ -219,7 +220,7 @@ genLet tcm env hole = do   binds <- genLetBindings tcm env   let vars = fmap fst binds-  let env' = extendListUniqMap env (zip vars (fmap Right vars))+  let env' = UniqMap.insertMany (zip vars (fmap Right vars)) env    body <- genTermFrom tcm env' hole @@ -232,7 +233,7 @@   -> UniqMap (Either TyVar Id)   -> CoreGenT m [LetBinding] genLetBindings tcm env = do-  let tyEnv = mapMaybeUniqMap (either Just (const Nothing)) env+  let tyEnv = UniqMap.mapMaybe (either Just (const Nothing)) env   -- Limit the number of new bindings to 8 to prevent an explosion in the   -- number of sub-holes to generate.   types <- Gen.list (Range.linear 1 8) (genMonoTypeFrom tcm tyEnv liftedTypeKind)@@ -242,7 +243,7 @@     -- Bindings can be indirectly recursive, but not directly recursive. This     -- stops the generator from generating let x = x in ...     let vars' = filter (/= v) vars-        env' = extendListUniqMap env (zip vars' (fmap Right vars'))+        env' = UniqMap.insertMany (zip vars' (fmap Right vars')) env      in (v,) <$> genTermFrom tcm env' ty  {-@@ -285,13 +286,13 @@   -- I need to select something as the subject. It can be any type, but should   -- bias towards something from the environment where possible. It may not be   -- possible though, so I should be able to fallback to just building a term.-  let tmEnv = mapMaybeUniqMap (either (const Nothing) Just) env+  let tmEnv = UniqMap.mapMaybe (either (const Nothing) Just) env   subj <- sampleSubjFrom tmEnv   let subjTy = inferCoreTypeOf tcm subj    case fmap fst (splitTyConAppM subjTy) of     Just tcn ->-      case lookupUniqMap tcn tcm of+      case UniqMap.lookup tcn tcm of         Just tc@AlgTyCon{} -> do           dcs <- Gen.subsequence (tyConDataCons tc)           dcPats <- traverse genDataPatFrom dcs@@ -335,7 +336,7 @@     let toIdBind x = (varUniq x, Right x)      -- Generate the terms in alternatives with the newly bound vars in scope.-    let env' = extendListUniqMap env (fmap toTvBind tvs <> fmap toIdBind ids)+    let env' = UniqMap.insertMany (fmap toTvBind tvs <> fmap toIdBind ids) env     term <- genTermFrom tcm env' altTy      pure (pat, term)

@@ -27,7 +27,8 @@ import Clash.Core.TysPrim (liftedTypeKind, tysPrimMap) import Clash.Core.Var import Clash.Core.VarEnv-import Clash.Unique+import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Core.DataCon import Clash.Hedgehog.Core.Monad@@ -73,7 +74,7 @@  -- | A TyConMap contains all the algebraic data types and type families that -- are used in a program. This is typically the first thing that should be--- generated, as calls to other generators like 'genKind' or 'genTypeFrom' will+-- generated, as calls to other generators like @genKind@ or @genTypeFrom@ will -- likely want to use the type constructors added to the TyConMap. -- -- TODO It would be nice if this also included types from @clash-prelude@ like@@ -104,7 +105,7 @@         ]       False -> Gen.choice [genAlgTyConFrom numDcs tcm] -    pure (unionUniqMap tcm new)+    pure (tcm <> new)  -- | Generate a new algebraic type constructor using the types that are already -- in scope. This will also promote data constructors if the configuration@@ -117,7 +118,7 @@   -> TyConMap   -> CoreGenT m TyConMap genAlgTyConFrom range tcm = do-  let used = uniqMapToUniqSet (fmap tyConUniq tcm)+  let used = fmap tyConUniq tcm   name <- genFreshName used genTyConName    -- TODO We want to use this, but we cannot sample polymorphic constructors@@ -143,10 +144,10 @@     True ->       -- Promote all the data constructors in the TyCon.       let dcs = tyConDataCons tc-       in pure (listToUniqMap ((name, tc) : fmap promoteDataCon dcs))+       in pure (UniqMap.fromList ((name, tc) : fmap promoteDataCon dcs))      False ->-      pure (unitUniqMap name tc)+      pure (UniqMap.singleton name tc)  where    promoteDataCon dc =      let tcn = coerce (dcName dc)@@ -167,7 +168,7 @@   => TyConMap   -> CoreGenT m TyConMap genFunTyConFrom tcm = do-  let used = uniqMapToUniqSet (fmap tyConUniq tcm)+  let used = fmap tyConUniq tcm   name <- genFreshName used genTyConName    kn <- genClosedKindFrom tcm liftedTypeKind@@ -177,21 +178,21 @@   substs <- genSubsts name (rights argKns) resKn    let tc = FunTyCon (nameUniq name) name kn arity substs-  pure (unitUniqMap name tc)+  pure (UniqMap.singleton name tc)  where   genSubsts :: TyConName -> [Kind] -> Kind -> CoreGenT m [([Type], Type)]   genSubsts _ [] rhsKn = do     -- Nullary type family, we only need to generate the RHS type-    let tcm' = filterUniqMap (not . isPrimTc) tcm-    rhs <- genMonoTypeFrom tcm' emptyUniqMap rhsKn+    let tcm' = UniqMap.filter (not . isPrimTc) tcm+    rhs <- genMonoTypeFrom tcm' mempty rhsKn      pure [([], rhs)]    genSubsts name argKns rhsKn = do-    let tcm' = filterUniqMap (not . isPrimTc) tcm+    let tcm' = UniqMap.filter (not . isPrimTc) tcm      tvs <- genVars genTyVar argKns genVarName-    let acc = fmap (\x -> (unitUniqMap x x, VarTy x)) tvs+    let acc = fmap (\x -> (UniqMap.singletonUnique x, VarTy x)) tvs      lhss <- refineArgs tcm acc @@ -247,13 +248,13 @@   -> Type   -> m (UniqMap TyVar, Type) refineArg tcm free ty-  | nullUniqMap free+  | UniqMap.null free   = pure (free, ty)    | otherwise   = do -- Pick a free variable and remove it from free vars        fv <- fst <$> sampleAnyUniqMap free-       let free' = delUniqMap free fv+       let free' = UniqMap.delete fv free         -- Pick a type constructor that fits that free variable. This cannot be        -- an unboxed primitive type, so for now all primitive types are excluded.@@ -262,11 +263,11 @@         -- Take any holes for that constructor and make them new free variables.        holeVars <- genVars genTyVar holes genVarName-       let free'' = extendListUniqMap free' (zip holeVars holeVars)+       let free'' = UniqMap.insertMany (zip holeVars holeVars) free'         -- Substitute the removed free variable for the type constructor with        -- any new free variables applied to it.-       let inScope = extendInScopeSetList emptyInScopeSet (eltsUniqMap free'')+       let inScope = extendInScopeSetList emptyInScopeSet (UniqMap.elems free'')        let substTv = unitVarEnv fv (mkTyConApp (tyConName tc) (fmap VarTy holeVars))        let subst = mkTvSubst inScope substTv 

@@ -31,7 +31,8 @@ import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.TysPrim-import Clash.Unique+import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Core.Monad import Clash.Hedgehog.Core.Name@@ -40,7 +41,7 @@  -- | Classify a type or kind according to some criteria. The classification -- of a type or kind is used to determine the pre-defined types / kinds which--- can be used in hole fills. See 'classify' and 'useTyCon'.+-- can be used in hole fills. See @classify@ and @useTyCon@. -- data Class = Class   { cData :: !Any -- ^ Uses -XDataKinds@@ -75,9 +76,9 @@         mempty { cRankN = Any (isPolyTy a) } <> go a <> go b        TyConApp tcn args ->-        let tc = lookupUniqMap' tcm tcn+        let tc = UniqMap.find tcn tcm             isPoly = isPolyTy (piResultTys tcm (tyConKind tc) args)-         in case lookupUniqMap' tcm tcn of+         in case UniqMap.find tcn tcm of               AlgTyCon{} ->                 -- If the constructor is algebraic then we have -XDataKinds if                 -- we are classifying a Kind instead of a Type.@@ -130,7 +131,7 @@           ConstTy _ -> error ("classify: Naked ConstTy: " <> showPpr ty)  -- | Decide whether to use a type constructor based on the configuration and--- the result of 'classifyKind'. A type constructor is not usable if it uses+-- the result of @classifyKind@. A type constructor is not usable if it uses -- any features which are not included in the current configuration. -- useTyCon :: Bool -> CoreGenConfig -> TyConMap -> TyCon -> Bool@@ -191,7 +192,7 @@   -> Kind   -> CoreGenT m Kind genClosedKindFrom tcm =-  genKindFrom tcm emptyUniqMap+  genKindFrom tcm mempty  -- | Generate a kind which is valid for the given 'TyConMap'. The kind may -- contain free variables which are given in a 'UniqMap', and is a valid fit@@ -244,7 +245,7 @@   -> Kind   -> CoreGenT m Type genClosedPolyType tcm =-  genPolyTypeFrom tcm emptyUniqMap+  genPolyTypeFrom tcm mempty  -- | Generate a polymorphic type which is valid for the given environment. -- The generated type should have the specified kind, and may contain the@@ -278,7 +279,7 @@   -> Kind   -> CoreGenT m Type genClosedMonoType tcm =-  genMonoTypeFrom tcm emptyUniqMap+  genMonoTypeFrom tcm mempty  -- | Generate a monomorphic type which is valid for the given environment. -- The generated type should have the specified kind, and may contain the@@ -359,8 +360,8 @@   -> (UniqMap TyVar -> Kind -> CoreGenT m KindOrType)   -> CoreGenT m KindOrType genForAll env k1 k2 genSub = do-  v <- genTyVar k1 (genFreshName (uniqMapToUniqSet env) genVarName)-  Gen.subterm (genSub (extendUniqMap v v env) k2) (ForAllTy v)+  v <- genTyVar k1 (genFreshName env genVarName)+  Gen.subterm (genSub (UniqMap.insertUnique v env) k2) (ForAllTy v)  -- | Generate a "fresh" kind. This involves using the shape of the hole to -- generate a layer of the result kind, then solving any subgoal with either@@ -392,7 +393,7 @@ genPolyKind tcm env hole   -- Hole: forall v. a   | ForAllTy v a <- hole-  = let env' = extendUniqMap v v env+  = let env' = UniqMap.insertUnique v env      in Gen.subterm (genKindFrom tcm env' a) (ForAllTy v)    -- Hole: a -> b@@ -438,7 +439,7 @@ genMonoKind tcm env hole   -- Hole: C   | ConstTy (TyCon tcn) <- hole-  , Just tc <- lookupUniqMap tcn tcm+  , Just tc <- UniqMap.lookup tcn tcm   , let dcs = tyConDataCons tc   , not (null dcs)   = do dc <- Gen.element dcs@@ -477,7 +478,7 @@   -> CoreGenT m Type genFreshPolyType tcm env hole   | ForAllTy tv kn <- hole-  = let env' = extendUniqMap tv tv env+  = let env' = UniqMap.insertUnique tv env      in Gen.subterm (genPolyTypeFrom tcm env' kn) (ForAllTy tv)    | FunTy a b <- tyView hole@@ -514,7 +515,7 @@   -> CoreGenT m Type genFreshMonoType tcm env hole   | ConstTy (TyCon tcn) <- hole-  , Just tc <- lookupUniqMap tcn tcm+  , Just tc <- UniqMap.lookup tcn tcm   , let dcs = tyConDataCons tc   , not (null dcs)   = do dc <- Gen.element dcs

@@ -7,37 +7,24 @@ -}  module Clash.Hedgehog.Core.Var-  ( genAttr'-  , genTyVar+  ( genTyVar   , genId   , genLocalId   , genGlobalId   , genVars   ) where -import Hedgehog (MonadGen, Range)+import Hedgehog (MonadGen) import qualified Hedgehog.Gen as Gen  import Clash.Core.Name (Name(nameUniq)) import Clash.Core.Term (TmName) import Clash.Core.Type (Kind, KindOrType, TyName, Type)-import Clash.Core.Var (Attr'(..), Id, IdScope(..), TyVar, Var(..))-import Clash.Unique+import Clash.Core.Var (Id, IdScope(..), TyVar, Var(..))+import qualified Clash.Data.UniqMap as UniqMap  import Clash.Hedgehog.Core.Name (genFreshName) -genAttr' :: forall m. MonadGen m => Range Int -> m Attr'-genAttr' range =-  Gen.choice-    [ BoolAttr' <$> genAlphaNum <*> Gen.bool-    , IntegerAttr' <$> genAlphaNum <*> genInteger-    , StringAttr' <$> genAlphaNum <*> genAlphaNum-    , Attr' <$> genAlphaNum-    ]- where-  genAlphaNum = Gen.string range Gen.alphaNum-  genInteger  = toInteger <$> Gen.integral range- -- | Generate a fresh type variable of the specified kind. genTyVar :: forall m. MonadGen m => Kind -> m TyName -> m TyVar genTyVar kn genName = do@@ -54,12 +41,18 @@ -- | Generate a fresh local identifier of the specified kind. genLocalId :: forall m. MonadGen m => Type -> m TmName -> m Id genLocalId ty =-  fmap (\i -> i { idScope = LocalId }) . genId ty+  fmap setToLocal . genId ty+ where+  setToLocal i@Id{} = i {idScope = LocalId}+  setToLocal i = i  -- | Generate a fresh global identifier of the specified kind. genGlobalId :: forall m. MonadGen m => Type -> m TmName -> m Id genGlobalId ty =-  fmap (\i -> i { idScope = GlobalId }) . genId ty+  fmap setToGlobal . genId ty+ where+  setToGlobal i@Id{} = i {idScope = LocalId}+  setToGlobal i = i  mapAccumLM   :: forall m acc x y@@ -87,8 +80,8 @@   -> m (Name a)   -> m [Var a] genVars genVar kts genName =-  snd <$> mapAccumLM go emptyUniqSet kts+  snd <$> mapAccumLM go mempty kts  where   go used kt = do     var <- genVar kt (genFreshName used genName)-    pure (extendUniqSet used var, var)+    pure (UniqMap.insertUnique var used, var)

@@ -6,6 +6,8 @@ Bias for influencing generator choice. -} +{-# LANGUAGE CPP #-}+ module Clash.Hedgehog.Internal.Bias   ( Bias(..)   ) where@@ -51,7 +53,9 @@     | aeqType ty charPrimTy       = biasBy 2  -- Char#, ByteArray#, Addr#     | aeqType ty byteArrayPrimTy  = biasBy 2     | aeqType ty stringPrimTy     = biasBy 2+#if !MIN_VERSION_base(4,16,0)     | aeqType ty voidPrimTy       = biasBy 1  -- Void#+#endif      | otherwise                   = baseBias  -- Anything else is base    where

@@ -13,7 +13,6 @@   , genUniqMap   , sampleUniqMap   , sampleAnyUniqMap-  , genUniqSet   , Bias(..)   , sampleUniqMapBiased   ) where@@ -27,6 +26,8 @@ import Clash.Core.HasType import Clash.Core.Subst (aeqType) import Clash.Core.Type+import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap import Clash.Unique  import Clash.Hedgehog.Internal.Bias@@ -42,7 +43,7 @@   -> m v   -> m (UniqMap v) genUniqMap range genKey genValue =-  listToUniqMap <$> Gen.list range ((,) <$> genKey <*> genValue)+  UniqMap.fromList <$> Gen.list range ((,) <$> genKey <*> genValue)  sampleAnyUniqMap   :: forall m v@@ -50,9 +51,9 @@   => UniqMap v   -> m (v, [Type]) sampleAnyUniqMap xs =-  let xs' = filterUniqMap (not . isPolyTy . coreTypeOf) xs-   in if nullUniqMap xs' then empty else do-     x <- Gen.element (eltsUniqMap xs')+  let xs' = UniqMap.filter (not . isPolyTy . coreTypeOf) xs+   in if UniqMap.null xs' then empty else do+     x <- Gen.element (UniqMap.elems xs')      let holes = rights . fst $ splitFunForallTy (coreTypeOf x)       pure (x, holes)@@ -65,8 +66,8 @@   -> UniqMap v   -> m (v, [Type]) sampleUniqMap p hole xs =-  let xs' = mapMaybeUniqMap findFit (filterUniqMap p xs)-   in if nullUniqMap xs' then empty else Gen.element (eltsUniqMap xs')+  let xs' = UniqMap.mapMaybe findFit (UniqMap.filter p xs)+   in if UniqMap.null xs' then empty else Gen.element (UniqMap.elems xs')  where   findFit x =     fmap (x,) (findFitArgs (coreTypeOf x))@@ -101,7 +102,7 @@   -> UniqMap v   -> m (v, [Type]) sampleUniqMapBiased p hole xs =-  let xs' = eltsUniqMap $ mapMaybeUniqMap findFit (filterUniqMap p xs)+  let xs' = UniqMap.elems $ UniqMap.mapMaybe findFit (UniqMap.filter p xs)       bs  = fmap (biasOf . fst) xs'    in if null xs' then empty else Gen.frequency (zip bs (Gen.constant <$> xs'))   where@@ -112,12 +113,3 @@     | aeqType hole a        = Just []     | FunTy b c <- tyView a = fmap (b :) (findFitArgs c)     | otherwise             = Nothing--genUniqSet-  :: forall m v-   . (MonadGen m, Uniquable v)-  => Range Int-  -> m v-  -> m (UniqSet v)-genUniqSet range genValue =-  mkUniqSet <$> Gen.list range genValue