Last active
March 9, 2022 13:43
-
-
Save edsko/955beb26913144dc29a2e17c68435488 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DerivingStrategies #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
module Data.Record.Internal.GHC.Fresh ( | |
MonadFresh(..) | |
, runFreshHsc | |
) where | |
import Data.IORef | |
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: | |
-- | |
-- o These names should be used for module exports. | |
-- o These names should be used for exactly /one/ binder. | |
freshExpVar :: LRdrName -> m LRdrName | |
-- | Like 'freshExpVar', but for use as a type variable instead | |
freshTyVar :: LRdrName -> m LRdrName | |
newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT (IORef NameCache) IO a } | |
deriving newtype (Functor, Applicative, Monad) | |
instance MonadFresh Fresh where | |
freshExpVar = freshVar mkVarOcc | |
freshTyVar = freshVar mkTyVarOcc | |
-- | Internal auxiliary | |
freshVar :: ([Char] -> OccName) -> GenLocated SrcSpan RdrName -> Fresh LRdrName | |
freshVar mkOcc (L l name) = WrapFresh $ ReaderT $ \nc_var -> | |
atomicModifyIORef nc_var aux | |
where | |
aux :: NameCache -> (NameCache, LRdrName) | |
aux nc = ( | |
nc { nsUniqs = us } | |
, L l $ Exact $ | |
mkInternalName newUniq (newOccName (rdrNameOcc name)) l | |
) | |
where | |
(newUniq, us) = takeUniqFromSupply (nsUniqs nc) | |
-- 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 = mkOcc . ("_" ++) . occNameString | |
runFresh :: Fresh a -> IORef NameCache -> IO a | |
runFresh = runReaderT . unwrapFresh | |
runFreshHsc :: Fresh a -> Hsc a | |
runFreshHsc fa = do | |
env <- getHscEnv | |
liftIO $ runFresh fa (hsc_NC env) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment