{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Fresh name generation
module Data.Record.Anon.Internal.Plugin.Source.FreshT (
    -- * Monad definition
    FreshT -- opaque
  , runFreshT
  , runFreshHsc
    -- * Generate fresh names
  , fresh
  , freshVar
  ) where

import Control.Monad.Reader

import Data.Record.Anon.Internal.Plugin.Source.GhcShim

{-------------------------------------------------------------------------------
  Monad definition
-------------------------------------------------------------------------------}

-- | Fresh name generation
newtype FreshT m a = WrapFreshT {
      forall (m :: * -> *) a. FreshT m a -> ReaderT NameCacheIO m a
unwrapNamingT :: ReaderT NameCacheIO m a
    }
  deriving (forall a b. a -> FreshT m b -> FreshT m a
forall a b. (a -> b) -> FreshT m a -> FreshT m b
forall (m :: * -> *) a b.
Functor m =>
a -> FreshT m b -> FreshT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> FreshT m a -> FreshT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FreshT m b -> FreshT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> FreshT m b -> FreshT m a
fmap :: forall a b. (a -> b) -> FreshT m a -> FreshT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> FreshT m a -> FreshT m b
Functor, forall a. a -> FreshT m a
forall a b. FreshT m a -> FreshT m b -> FreshT m a
forall a b. FreshT m a -> FreshT m b -> FreshT m b
forall a b. FreshT m (a -> b) -> FreshT m a -> FreshT m b
forall a b c.
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
forall (f :: * -> *).
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 {m :: * -> *}. Applicative m => Functor (FreshT m)
forall (m :: * -> *) a. Applicative m => a -> FreshT m a
forall (m :: * -> *) a b.
Applicative m =>
FreshT m a -> FreshT m b -> FreshT m a
forall (m :: * -> *) a b.
Applicative m =>
FreshT m a -> FreshT m b -> FreshT m b
forall (m :: * -> *) a b.
Applicative m =>
FreshT m (a -> b) -> FreshT m a -> FreshT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
<* :: forall a b. FreshT m a -> FreshT m b -> FreshT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
FreshT m a -> FreshT m b -> FreshT m a
*> :: forall a b. FreshT m a -> FreshT m b -> FreshT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
FreshT m a -> FreshT m b -> FreshT m b
liftA2 :: forall a b c.
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
<*> :: forall a b. FreshT m (a -> b) -> FreshT m a -> FreshT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
FreshT m (a -> b) -> FreshT m a -> FreshT m b
pure :: forall a. a -> FreshT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> FreshT m a
Applicative, forall a. a -> FreshT m a
forall a b. FreshT m a -> FreshT m b -> FreshT m b
forall a b. FreshT m a -> (a -> FreshT m b) -> FreshT m b
forall {m :: * -> *}. Monad m => Applicative (FreshT m)
forall (m :: * -> *) a. Monad m => a -> FreshT m a
forall (m :: * -> *) a b.
Monad m =>
FreshT m a -> FreshT m b -> FreshT m b
forall (m :: * -> *) a b.
Monad m =>
FreshT m a -> (a -> FreshT m b) -> FreshT m b
forall (m :: * -> *).
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 -> FreshT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> FreshT m a
>> :: forall a b. FreshT m a -> FreshT m b -> FreshT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
FreshT m a -> FreshT m b -> FreshT m b
>>= :: forall a b. FreshT m a -> (a -> FreshT m b) -> FreshT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
FreshT m a -> (a -> FreshT m b) -> FreshT m b
Monad)

instance MonadTrans FreshT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> FreshT m a
lift = forall (m :: * -> *) a. ReaderT NameCacheIO m a -> FreshT m a
WrapFreshT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runFreshT :: NameCacheIO -> FreshT m a -> m a
runFreshT :: forall (m :: * -> *) a. NameCacheIO -> FreshT m a -> m a
runFreshT NameCacheIO
ncVar = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT NameCacheIO
ncVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. FreshT m a -> ReaderT NameCacheIO m a
unwrapNamingT

runFreshHsc :: FreshT Hsc a -> Hsc a
runFreshHsc :: forall a. FreshT Hsc a -> Hsc a
runFreshHsc FreshT Hsc a
ma = do
    HscEnv
env <- Hsc HscEnv
getHscEnv
    forall (m :: * -> *) a. NameCacheIO -> FreshT m a -> m a
runFreshT (HscEnv -> NameCacheIO
hscNameCacheIO HscEnv
env) FreshT Hsc a
ma

{-------------------------------------------------------------------------------
  Key features of FreshT
-------------------------------------------------------------------------------}

fresh :: MonadIO m => SrcSpan -> RdrName -> FreshT m RdrName
fresh :: forall (m :: * -> *).
MonadIO m =>
SrcSpan -> RdrName -> FreshT m RdrName
fresh SrcSpan
l RdrName
name = forall (m :: * -> *) a. ReaderT NameCacheIO m a -> FreshT m a
WrapFreshT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \NameCacheIO
nc -> do
    Unique
newUniq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NameCacheIO -> IO Unique
takeUniqFromNameCacheIO NameCacheIO
nc
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ OccName -> String
occNameString OccName
n

{-------------------------------------------------------------------------------
  Derived convenience functions
-------------------------------------------------------------------------------}

freshVar :: MonadIO m => SrcSpan -> String -> FreshT m RdrName
freshVar :: forall (m :: * -> *).
MonadIO m =>
SrcSpan -> String -> FreshT m RdrName
freshVar SrcSpan
l = forall (m :: * -> *).
MonadIO m =>
SrcSpan -> RdrName -> FreshT m RdrName
fresh SrcSpan
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc