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

Random generation of names.
-}

module Clash.Hedgehog.Core.Name
  ( genKindName
  , genTypeName
  , genTyConName
  , genTermName
  , genDataConName
  , genVarName
  , genFreshName
  , genNames
  ) where

import Control.Monad.Morph (hoist)
import Data.Functor.Identity (Identity(runIdentity))
import qualified Data.Text as Text
import qualified Faker.Lorem as Fake
import Hedgehog (GenT, MonadGen(GenBase, fromGenT))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Gen.Faker as Gen

import Clash.Core.DataCon (DcName)
import Clash.Core.Term (TmName)
import Clash.Core.TyCon (TyConName)
import Clash.Core.Type (KiName, TyName)
import Clash.Core.Name
import Clash.Data.UniqMap (UniqMap)
import qualified Clash.Data.UniqMap as UniqMap

import Clash.Hedgehog.Unique (genUnique)

-- | Generate a name by applying a function to arbitrary text. This is used to
-- ensure that names have the correct case for the thing being named.
--
genOccNameWith :: forall m. MonadGen m => (OccName -> OccName) -> m OccName
genOccNameWith :: (OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
f =
  GenT (GenBase m) OccName -> m OccName
forall (m :: Type -> Type) a.
MonadGen m =>
GenT (GenBase m) a -> m a
fromGenT (GenT (GenBase m) OccName -> m OccName)
-> GenT (GenBase m) OccName -> m OccName
forall a b. (a -> b) -> a -> b
$ (forall a. Identity a -> GenBase m a)
-> GenT Identity OccName -> GenT (GenBase m) OccName
forall k (t :: (Type -> Type) -> k -> Type) (m :: Type -> Type)
       (n :: Type -> Type) (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist @GenT @Identity @(GenBase m)
    (a -> GenBase m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a -> GenBase m a)
-> (Identity a -> a) -> Identity a -> GenBase m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity)
    ((OccName -> OccName)
-> GenT Identity OccName -> GenT Identity OccName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap OccName -> OccName
f (Fake OccName -> GenT Identity OccName
forall a. Fake a -> Gen a
Gen.fake Fake OccName
Fake.words))

genName :: forall m a. MonadGen m => m OccName -> m (Name a)
genName :: m OccName -> m (Name a)
genName m OccName
genOccName =
  NameSort -> OccName -> Unique -> SrcSpan -> Name a
forall a. NameSort -> OccName -> Unique -> SrcSpan -> Name a
Name
    (NameSort -> OccName -> Unique -> SrcSpan -> Name a)
-> m NameSort -> m (OccName -> Unique -> SrcSpan -> Name a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [NameSort] -> m NameSort
forall (f :: Type -> Type) (m :: Type -> Type) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element [NameSort
User, NameSort
System, NameSort
Internal]
    m (OccName -> Unique -> SrcSpan -> Name a)
-> m OccName -> m (Unique -> SrcSpan -> Name a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m OccName
genOccName
    m (Unique -> SrcSpan -> Name a)
-> m Unique -> m (SrcSpan -> Name a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> m Unique
forall (m :: Type -> Type). MonadGen m => m Unique
genUnique
    m (SrcSpan -> Name a) -> m SrcSpan -> m (Name a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SrcSpan -> m SrcSpan
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SrcSpan
noSrcSpan

genKindName :: forall m. MonadGen m => m KiName
genKindName :: m KiName
genKindName = m OccName -> m KiName
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toTitle)

genTypeName :: forall m. MonadGen m => m TyName
genTypeName :: m KiName
genTypeName = m OccName -> m KiName
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toTitle)

genTyConName :: forall m. MonadGen m => m TyConName
genTyConName :: m TyConName
genTyConName = m OccName -> m TyConName
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toTitle)

genTermName :: forall m. MonadGen m => m TmName
genTermName :: m TmName
genTermName = m OccName -> m TmName
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toLower)

genDataConName :: forall m. MonadGen m => m DcName
genDataConName :: m DcName
genDataConName = m OccName -> m DcName
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toTitle)

genVarName :: forall m a. MonadGen m => m (Name a)
genVarName :: m (Name a)
genVarName = m OccName -> m (Name a)
forall (m :: Type -> Type) a. MonadGen m => m OccName -> m (Name a)
genName ((OccName -> OccName) -> m OccName
forall (m :: Type -> Type).
MonadGen m =>
(OccName -> OccName) -> m OccName
genOccNameWith OccName -> OccName
Text.toLower)

-- | Generate a name using the given generator, while ensuring the unique of
-- the generated name does not occur in the given @UniqMap@.
--
genFreshName
  :: forall m a b
   . MonadGen m
  => UniqMap b
  -> m (Name a)
  -> m (Name a)
genFreshName :: UniqMap b -> m (Name a) -> m (Name a)
genFreshName UniqMap b
used =
  (Name a -> Bool) -> m (Name a) -> m (Name a)
forall (m :: Type -> Type) a.
MonadGen m =>
(a -> Bool) -> m a -> m a
Gen.filterT (Bool -> Bool
not (Bool -> Bool) -> (Name a -> Bool) -> Name a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique -> UniqMap b -> Bool) -> UniqMap b -> Unique -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Unique -> UniqMap b -> Bool
forall a b. Uniquable a => a -> UniqMap b -> Bool
UniqMap.elem UniqMap b
used (Unique -> Bool) -> (Name a -> Unique) -> Name a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name a -> Unique
forall a. Name a -> Unique
nameUniq)

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 names, from a supplied function to generate names
-- and the number of names to generate.
--
-- TODO While this gives "unique" names because the uniques are different, it
-- can generate multiple names with the same OccName.
genNames
  :: forall m a
   . MonadGen m
  => Int
  -> m (Name a)
  -> m [Name a]
genNames :: Unique -> m (Name a) -> m [Name a]
genNames Unique
n m (Name a)
gen =
  (UniqMap (Name a), [Name a]) -> [Name a]
forall a b. (a, b) -> b
snd ((UniqMap (Name a), [Name a]) -> [Name a])
-> m (UniqMap (Name a), [Name a]) -> m [Name a]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (UniqMap (Name a) -> Unique -> m (UniqMap (Name a), Name a))
-> UniqMap (Name a) -> [Unique] -> m (UniqMap (Name a), [Name a])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM UniqMap (Name a) -> Unique -> m (UniqMap (Name a), Name a)
go UniqMap (Name a)
forall a. Monoid a => a
mempty [Unique
1..Unique
n]
 where
   go :: UniqMap (Name a) -> Unique -> m (UniqMap (Name a), Name a)
go UniqMap (Name a)
used Unique
_ = do
    Name a
name <- UniqMap (Name a) -> m (Name a) -> m (Name a)
forall (m :: Type -> Type) a b.
MonadGen m =>
UniqMap b -> m (Name a) -> m (Name a)
genFreshName UniqMap (Name a)
used m (Name a)
gen
    (UniqMap (Name a), Name a) -> m (UniqMap (Name a), Name a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name a -> UniqMap (Name a) -> UniqMap (Name a)
forall a. Uniquable a => a -> UniqMap a -> UniqMap a
UniqMap.insertUnique Name a
name UniqMap (Name a)
used, Name a
name)