{-|
Copyright : (C) 2021, QBayLogic B.V.
License : BSD2 (see the file LICENSE)
Maintainer : QBayLogic B.V. <devops@qbaylogic.com>
Random generation of unique variables and unique containers.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Clash.Hedgehog.Unique
( genUnique
, genUniqMap
, sampleUniqMap
, sampleAnyUniqMap
, Bias(..)
, sampleUniqMapBiased
) where
#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))
#define UNIQUE_IS_WORD64
#endif
import Control.Applicative (Alternative(empty))
import Data.Either (rights)
import Hedgehog (MonadGen, Range)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
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
genUnique :: forall m. MonadGen m => m Unique
genUnique =
#ifdef UNIQUE_IS_WORD64
Gen.word64
#else
Gen.int
#endif
Range.linearBounded
genUniqMap
:: forall m k v
. (MonadGen m, Uniquable k)
=> Range Int
-> m k
-> m v
-> m (UniqMap v)
genUniqMap range genKey genValue =
UniqMap.fromList <$> Gen.list range ((,) <$> genKey <*> genValue)
sampleAnyUniqMap
:: forall m v
. (Alternative m, MonadGen m, HasType v)
=> UniqMap v
-> m (v, [Type])
sampleAnyUniqMap 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)
sampleUniqMap
:: forall m v
. (Alternative m, MonadGen m, HasType v)
=> (v -> Bool)
-> Type
-> UniqMap v
-> m (v, [Type])
sampleUniqMap p hole 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))
-- NOTE [finding more complex fits]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- This is not good enough. If I have a hole of type A -> B and I have
-- a candidate of type forall a. a -> B, I will give up because it is not
-- alpha equalivalent or a function type. I could return [Either TyVar Type]
-- and include foralls, but this would still not fit polymorphic holes. For
-- example, if I have the hole A -> B, and the candidate forall a. a -> B, it
-- would:
--
-- 1. not aeq to hole, add Left a to params
-- 2. not aeq to hole, add Right a to params
-- 3. not aeq to hole, discard
--
-- The correct approach to take here is to figure out which arguments need
-- to be provided such that the hole and the type of the candidate can be
-- unified. However, unification is (1) not provided by clash-lib currently
-- and (2) very non-trivial to implement given we have -XTypeFamilies.
findFitArgs a
| aeqType hole a = Just []
| FunTy b c <- tyView a = fmap (b :) (findFitArgs c)
| otherwise = Nothing
sampleUniqMapBiased
:: forall m v
. (Alternative m, MonadGen m, HasType v, Bias v)
=> (v -> Bool)
-> Type
-> UniqMap v
-> m (v, [Type])
sampleUniqMapBiased p hole 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
findFit x =
fmap (x,) (findFitArgs (coreTypeOf x))
findFitArgs a
| aeqType hole a = Just []
| FunTy b c <- tyView a = fmap (b :) (findFitArgs c)
| otherwise = Nothing