{-# 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 -> b) -> FreshT m a -> FreshT m b)
-> (forall a b. a -> FreshT m b -> FreshT m a)
-> Functor (FreshT m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> FreshT m a -> FreshT m b
fmap :: forall a b. (a -> b) -> FreshT m a -> FreshT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> FreshT m b -> FreshT m a
<$ :: forall a b. a -> FreshT m b -> FreshT m a
Functor, Functor (FreshT m)
Functor (FreshT m) =>
(forall a. a -> FreshT m a)
-> (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 a b. FreshT m a -> FreshT m b -> FreshT m b)
-> (forall a b. FreshT m a -> FreshT m b -> FreshT m a)
-> Applicative (FreshT m)
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
$cpure :: forall (m :: * -> *) a. Applicative m => a -> FreshT m a
pure :: forall a. a -> FreshT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
FreshT m (a -> b) -> FreshT m a -> FreshT m b
<*> :: forall a b. FreshT m (a -> b) -> FreshT m a -> FreshT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
liftA2 :: forall a b c.
(a -> b -> c) -> FreshT m a -> FreshT m b -> FreshT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
FreshT m a -> FreshT m b -> FreshT m b
*> :: 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 a
<* :: forall a b. FreshT m a -> FreshT m b -> FreshT m a
Applicative, Applicative (FreshT m)
Applicative (FreshT m) =>
(forall a b. FreshT m a -> (a -> FreshT m b) -> FreshT m b)
-> (forall a b. FreshT m a -> FreshT m b -> FreshT m b)
-> (forall a. a -> FreshT m a)
-> Monad (FreshT m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
FreshT m a -> (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 -> FreshT m b -> FreshT m b
>> :: forall a b. FreshT m a -> FreshT m b -> FreshT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> FreshT m a
return :: forall a. a -> FreshT m a
Monad)

instance MonadTrans FreshT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> FreshT m a
lift = ReaderT NameCacheIO m a -> FreshT m a
forall (m :: * -> *) a. ReaderT NameCacheIO m a -> FreshT m a
WrapFreshT (ReaderT NameCacheIO m a -> FreshT m a)
-> (m a -> ReaderT NameCacheIO m a) -> m a -> FreshT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT NameCacheIO m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT NameCacheIO m a
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 = (ReaderT NameCacheIO m a -> NameCacheIO -> m a)
-> NameCacheIO -> ReaderT NameCacheIO m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT NameCacheIO m a -> NameCacheIO -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT NameCacheIO
ncVar (ReaderT NameCacheIO m a -> m a)
-> (FreshT m a -> ReaderT NameCacheIO m a) -> FreshT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreshT m a -> ReaderT NameCacheIO m a
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
    NameCacheIO -> FreshT Hsc a -> Hsc a
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 = ReaderT NameCacheIO m RdrName -> FreshT m RdrName
forall (m :: * -> *) a. ReaderT NameCacheIO m a -> FreshT m a
WrapFreshT (ReaderT NameCacheIO m RdrName -> FreshT m RdrName)
-> ReaderT NameCacheIO m RdrName -> FreshT m RdrName
forall a b. (a -> b) -> a -> b
$ (NameCacheIO -> m RdrName) -> ReaderT NameCacheIO m RdrName
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((NameCacheIO -> m RdrName) -> ReaderT NameCacheIO m RdrName)
-> (NameCacheIO -> m RdrName) -> ReaderT NameCacheIO m RdrName
forall a b. (a -> b) -> a -> b
$ \NameCacheIO
nc -> do
    Unique
newUniq <- IO Unique -> m Unique
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> m Unique) -> IO Unique -> m Unique
forall a b. (a -> b) -> a -> b
$ NameCacheIO -> IO Unique
takeUniqFromNameCacheIO NameCacheIO
nc
    RdrName -> m RdrName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RdrName -> m RdrName) -> RdrName -> m RdrName
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
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) (String -> OccName) -> (String -> String) -> String -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> OccName) -> String -> OccName
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 = SrcSpan -> RdrName -> FreshT m RdrName
forall (m :: * -> *).
MonadIO m =>
SrcSpan -> RdrName -> FreshT m RdrName
fresh SrcSpan
l (RdrName -> FreshT m RdrName)
-> (String -> RdrName) -> String -> FreshT m RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> (String -> OccName) -> String -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkVarOcc