{-|
Copyright   : (C) 2021, QBayLogic B.V.
License     : BSD2 (see the file LICENSE)
Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>

Random generation of core variables.
-}

module Clash.Hedgehog.Core.Var
  ( genAttr'
  , genTyVar
  , genId
  , genLocalId
  , genGlobalId
  , genVars
  ) where

import Hedgehog (MonadGen, Range)
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.Hedgehog.Core.Name (genFreshName)

genAttr' :: forall m. MonadGen m => Range Int -> m Attr'
genAttr' :: Range Int -> m Attr'
genAttr' Range Int
range =
  [m Attr'] -> m Attr'
forall (m :: Type -> Type) a. MonadGen m => [m a] -> m a
Gen.choice
    [ String -> Bool -> Attr'
BoolAttr' (String -> Bool -> Attr') -> m String -> m (Bool -> Attr')
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
genAlphaNum m (Bool -> Attr') -> m Bool -> m Attr'
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m Bool
forall (m :: Type -> Type). MonadGen m => m Bool
Gen.bool
    , String -> Integer -> Attr'
IntegerAttr' (String -> Integer -> Attr') -> m String -> m (Integer -> Attr')
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
genAlphaNum m (Integer -> Attr') -> m Integer -> m Attr'
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m Integer
genInteger
    , String -> String -> Attr'
StringAttr' (String -> String -> Attr') -> m String -> m (String -> Attr')
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
genAlphaNum m (String -> Attr') -> m String -> m Attr'
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m String
genAlphaNum
    , String -> Attr'
Attr' (String -> Attr') -> m String -> m Attr'
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
genAlphaNum
    ]
 where
  genAlphaNum :: m String
genAlphaNum = Range Int -> m Char -> m String
forall (m :: Type -> Type).
MonadGen m =>
Range Int -> m Char -> m String
Gen.string Range Int
range m Char
forall (m :: Type -> Type). MonadGen m => m Char
Gen.alphaNum
  genInteger :: m Integer
genInteger  = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> m Int -> m Integer
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> m Int
forall (m :: Type -> Type) a.
(MonadGen m, Integral a) =>
Range a -> m a
Gen.integral Range Int
range

-- | Generate a fresh type variable of the specified kind.
genTyVar :: forall m. MonadGen m => Kind -> m TyName -> m TyVar
genTyVar :: Kind -> m TyName -> m TyVar
genTyVar Kind
kn m TyName
genName = do
  TyName
name <- m TyName
genName
  TyVar -> m TyVar
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TyName -> Int -> Kind -> TyVar
forall a. Name a -> Int -> Kind -> Var a
TyVar TyName
name (TyName -> Int
forall a. Name a -> Int
nameUniq TyName
name) Kind
kn)

-- | Generate a fresh identifier of the specified kind.
genId :: forall m. MonadGen m => Type -> m TmName -> m Id
genId :: Kind -> m TmName -> m Id
genId Kind
ty m TmName
genName = do
  TmName
name  <- m TmName
genName
  IdScope
scope <- [IdScope] -> m IdScope
forall (m :: Type -> Type) a. MonadGen m => [a] -> m a
Gen.element [IdScope
GlobalId, IdScope
LocalId]
  Id -> m Id
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TmName -> Int -> Kind -> IdScope -> Id
forall a. Name a -> Int -> Kind -> IdScope -> Var a
Id TmName
name (TmName -> Int
forall a. Name a -> Int
nameUniq TmName
name) Kind
ty IdScope
scope)

-- | Generate a fresh local identifier of the specified kind.
genLocalId :: forall m. MonadGen m => Type -> m TmName -> m Id
genLocalId :: Kind -> m TmName -> m Id
genLocalId Kind
ty =
  (Id -> Id) -> m Id -> m Id
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Id
i -> Id
i { idScope :: IdScope
idScope = IdScope
LocalId }) (m Id -> m Id) -> (m TmName -> m Id) -> m TmName -> m Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> m TmName -> m Id
forall (m :: Type -> Type). MonadGen m => Kind -> m TmName -> m Id
genId Kind
ty

-- | Generate a fresh global identifier of the specified kind.
genGlobalId :: forall m. MonadGen m => Type -> m TmName -> m Id
genGlobalId :: Kind -> m TmName -> m Id
genGlobalId Kind
ty =
  (Id -> Id) -> m Id -> m Id
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Id
i -> Id
i { idScope :: IdScope
idScope = IdScope
GlobalId }) (m Id -> m Id) -> (m TmName -> m Id) -> m TmName -> m Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> m TmName -> m Id
forall (m :: Type -> Type). MonadGen m => Kind -> m TmName -> m Id
genId Kind
ty

mapAccumLM
  :: forall m acc x y
   . Monad m
  => (acc -> x -> m (acc, y))
  -> acc
  -> [x]
  -> m (acc, [y])
mapAccumLM :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
_ acc
acc [] = (acc, [y]) -> m (acc, [y])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (acc
acc, [])
mapAccumLM acc -> x -> m (acc, y)
f acc
acc (x
x:[x]
xs) = do
  (acc
acc', y
y) <- acc -> x -> m (acc, y)
f acc
acc x
x
  (acc
acc'', [y]
ys) <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
acc' [x]
xs
  (acc, [y]) -> m (acc, [y])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (acc
acc'', y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
ys)

-- | Generate a collection of variables, from a supplied function to generate
-- variables and the kinds / types of variables to generate.
--
-- TODO While this gives "unique" vars because the uniques are different, it
-- can generate multiple vars with the same OccName.
genVars
  :: forall m a
   . MonadGen m
  => (KindOrType -> m (Name a) -> m (Var a))
  -> [KindOrType]
  -> m (Name a)
  -> m [Var a]
genVars :: (Kind -> m (Name a) -> m (Var a))
-> [Kind] -> m (Name a) -> m [Var a]
genVars Kind -> m (Name a) -> m (Var a)
genVar [Kind]
kts m (Name a)
genName =
  (UniqSet (Var a), [Var a]) -> [Var a]
forall a b. (a, b) -> b
snd ((UniqSet (Var a), [Var a]) -> [Var a])
-> m (UniqSet (Var a), [Var a]) -> m [Var a]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqSet (Var a) -> Kind -> m (UniqSet (Var a), Var a))
-> UniqSet (Var a) -> [Kind] -> m (UniqSet (Var a), [Var a])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM UniqSet (Var a) -> Kind -> m (UniqSet (Var a), Var a)
go UniqSet (Var a)
forall a. UniqSet a
emptyUniqSet [Kind]
kts
 where
  go :: UniqSet (Var a) -> Kind -> m (UniqSet (Var a), Var a)
go UniqSet (Var a)
used Kind
kt = do
    Var a
var <- Kind -> m (Name a) -> m (Var a)
genVar Kind
kt (UniqSet (Var a) -> m (Name a) -> m (Name a)
forall (m :: Type -> Type) a b.
MonadGen m =>
UniqSet b -> m (Name a) -> m (Name a)
genFreshName UniqSet (Var a)
used m (Name a)
genName)
    (UniqSet (Var a), Var a) -> m (UniqSet (Var a), Var a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UniqSet (Var a) -> Var a -> UniqSet (Var a)
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
extendUniqSet UniqSet (Var a)
used Var a
var, Var a
var)