Name.hs

{-|
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.Unique (UniqSet, elemUniqSetDirectly, emptyUniqSet, extendUniqSet)

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 f =
  fromGenT $ hoist @GenT @Identity @(GenBase m)
    (pure . runIdentity)
    (fmap f (Gen.fake Fake.words))

genName :: forall m a. MonadGen m => m OccName -> m (Name a)
genName genOccName =
  Name
    <$> Gen.element [User, System, Internal]
    <*> genOccName
    <*> genUnique
    <*> pure noSrcSpan

genKindName :: forall m. MonadGen m => m KiName
genKindName = genName (genOccNameWith Text.toTitle)

genTypeName :: forall m. MonadGen m => m TyName
genTypeName = genName (genOccNameWith Text.toTitle)

genTyConName :: forall m. MonadGen m => m TyConName
genTyConName = genName (genOccNameWith Text.toTitle)

genTermName :: forall m. MonadGen m => m TmName
genTermName = genName (genOccNameWith Text.toLower)

genDataConName :: forall m. MonadGen m => m DcName
genDataConName = genName (genOccNameWith Text.toTitle)

genVarName :: forall m a. MonadGen m => m (Name a)
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@.
--
genFreshName
  :: forall m a b
   . MonadGen m
  => UniqSet b
  -> m (Name a)
  -> m (Name a)
genFreshName used =
  Gen.filterT (not . flip elemUniqSetDirectly used . nameUniq)

mapAccumLM
  :: forall m acc x y
   . Monad m
  => (acc -> x -> m (acc, y))
  -> acc
  -> [x]
  -> m (acc, [y])
mapAccumLM _ acc [] = return (acc, [])
mapAccumLM f acc (x:xs) = do
  (acc', y) <- f acc x
  (acc'', ys) <- mapAccumLM f acc' xs
  return (acc'', 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 n gen =
  snd <$> mapAccumLM go emptyUniqSet [1..n]
 where
   go used _ = do
    name <- genFreshName used gen
    pure (extendUniqSet used name, name)