{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Data.Record.Internal.GHC.Fresh (
    MonadFresh(..)
  , runFreshHsc
  ) where

import Control.Monad.Reader

import Data.Record.Internal.GHC.Shim

class Monad m => MonadFresh m where
  -- | Construct a fresh name for use in term level expressions
  --
  -- NOTES:
  --
  -- * These names should be used for module exports.
  -- * These names should be used for exactly /one/ binder.
  -- * The resulting name has the same 'NameSpace' as the argument.
  freshName :: LRdrName -> m LRdrName
  freshName = forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
True

  -- variant which doesn't rename the variable.
  -- The 'False' variant can be used in types.
  freshName' :: Bool -> LRdrName -> m LRdrName

newtype Fresh a = WrapFresh { forall a. Fresh a -> ReaderT NameCacheIO IO a
unwrapFresh :: ReaderT NameCacheIO IO a }
  deriving newtype (forall a b. a -> Fresh b -> Fresh a
forall a b. (a -> b) -> Fresh a -> Fresh b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Fresh b -> Fresh a
$c<$ :: forall a b. a -> Fresh b -> Fresh a
fmap :: forall a b. (a -> b) -> Fresh a -> Fresh b
$cfmap :: forall a b. (a -> b) -> Fresh a -> Fresh b
Functor, Functor Fresh
forall a. a -> Fresh a
forall a b. Fresh a -> Fresh b -> Fresh a
forall a b. Fresh a -> Fresh b -> Fresh b
forall a b. Fresh (a -> b) -> Fresh a -> Fresh b
forall a b c. (a -> b -> c) -> Fresh a -> Fresh b -> Fresh c
forall (f :: Type -> Type).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Fresh a -> Fresh b -> Fresh a
$c<* :: forall a b. Fresh a -> Fresh b -> Fresh a
*> :: forall a b. Fresh a -> Fresh b -> Fresh b
$c*> :: forall a b. Fresh a -> Fresh b -> Fresh b
liftA2 :: forall a b c. (a -> b -> c) -> Fresh a -> Fresh b -> Fresh c
$cliftA2 :: forall a b c. (a -> b -> c) -> Fresh a -> Fresh b -> Fresh c
<*> :: forall a b. Fresh (a -> b) -> Fresh a -> Fresh b
$c<*> :: forall a b. Fresh (a -> b) -> Fresh a -> Fresh b
pure :: forall a. a -> Fresh a
$cpure :: forall a. a -> Fresh a
Applicative, Applicative Fresh
forall a. a -> Fresh a
forall a b. Fresh a -> Fresh b -> Fresh b
forall a b. Fresh a -> (a -> Fresh b) -> Fresh b
forall (m :: Type -> Type).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Fresh a
$creturn :: forall a. a -> Fresh a
>> :: forall a b. Fresh a -> Fresh b -> Fresh b
$c>> :: forall a b. Fresh a -> Fresh b -> Fresh b
>>= :: forall a b. Fresh a -> (a -> Fresh b) -> Fresh b
$c>>= :: forall a b. Fresh a -> (a -> Fresh b) -> Fresh b
Monad)

instance MonadFresh Fresh where
  freshName' :: Bool -> LRdrName -> Fresh LRdrName
freshName' Bool
pfx (L SrcSpan
l RdrName
name) = forall a. ReaderT NameCacheIO IO a -> Fresh a
WrapFresh forall a b. (a -> b) -> a -> b
$ forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \NameCacheIO
nc -> do
      Unique
newUniq <- NameCacheIO -> IO Unique
takeUniqFromNameCacheIO NameCacheIO
nc
      forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpan
l forall a b. (a -> b) -> a -> b
$ Name -> RdrName
Exact forall a b. (a -> b) -> a -> b
$
        Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
newUniq (OccName -> OccName
newOccName (RdrName -> OccName
rdrNameOcc RdrName
name)) SrcSpan
l
    where
      -- Even when we generate fresh names, ghc can still complain about name
      -- shadowing, because this check only considers the 'OccName', not the
      -- unique. We therefore prefix the name with an underscore to avoid the
      -- warning.
      newOccName :: OccName -> OccName
      newOccName :: OccName -> OccName
newOccName OccName
n = NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
n) forall a b. (a -> b) -> a -> b
$ String -> String
addPrefix forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
n

      addPrefix :: String -> String
      addPrefix :: String -> String
addPrefix = if Bool
pfx then (String
"_" forall a. [a] -> [a] -> [a]
++) else forall a. a -> a
id

runFresh :: Fresh a -> NameCacheIO -> IO a
runFresh :: forall a. Fresh a -> NameCacheIO -> IO a
runFresh = forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fresh a -> ReaderT NameCacheIO IO a
unwrapFresh

runFreshHsc :: Fresh a -> Hsc a
runFreshHsc :: forall a. Fresh a -> Hsc a
runFreshHsc Fresh a
fa = do
    HscEnv
env <- Hsc HscEnv
getHscEnv
    forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Fresh a -> NameCacheIO -> IO a
runFresh Fresh a
fa (HscEnv -> NameCacheIO
hscNameCacheIO HscEnv
env)