module Control.Monad.Trans.PreciseFresh (
Fresh
, runFresh
, evalFresh
, execFresh
, FreshT(..)
, freshT
, runFreshT
, evalFreshT
, execFreshT
, FreshState
, nothingUsed
, freshIdent
, freshIdents
, scopeFreshness
) where
import Control.Basics
import Control.Monad.Identity
import Control.Monad.State.Strict
import Control.Monad.Error
import Control.Monad.Reader
import qualified Data.Map as M
type FreshState = M.Map String Integer
newtype FreshT m a = FreshT { unFreshT :: StateT FreshState m a }
deriving( Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans )
freshT :: (FreshState -> m (a, FreshState)) -> FreshT m a
freshT = FreshT . StateT
nothingUsed :: FreshState
nothingUsed = M.empty
runFreshT :: FreshT m a -> FreshState -> m (a, FreshState)
runFreshT (FreshT m) used = runStateT m used
evalFreshT :: Monad m => FreshT m a -> FreshState -> m a
evalFreshT (FreshT m) used = evalStateT m used
execFreshT :: Monad m => FreshT m a -> FreshState -> m FreshState
execFreshT (FreshT m) used = execStateT m used
freshIdent :: Monad m => String -> FreshT m Integer
freshIdent name = do
m <- FreshT get
let i = M.findWithDefault 0 name m
!i' = succ i
FreshT (modify (M.insert name i'))
return i
freshIdents :: Monad m
=> Integer
-> FreshT m Integer
freshIdents k = do
m <- FreshT get
let maxIdx = maximum $ 0 : map snd (M.toList m)
nextIdx = maxIdx + k
FreshT (put (M.insert "" nextIdx $ M.map (const nextIdx) m))
return maxIdx
scopeFreshness :: Monad m => FreshT m a -> FreshT m a
scopeFreshness scoped = do
st <- FreshT get
x <- scoped
FreshT (put st)
return x
instance MonadError e m => MonadError e (FreshT m) where
throwError = lift . throwError
catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h)
instance MonadReader r m => MonadReader r (FreshT m) where
ask = lift ask
local f m = FreshT $ local f $ unFreshT m
instance MonadState s m => MonadState s (FreshT m) where
get = lift get
put s = lift $ put s
type Fresh = FreshT Identity
runFresh :: Fresh a -> FreshState -> (a, FreshState)
runFresh (FreshT m) used = runState m used
evalFresh :: Fresh a -> FreshState -> a
evalFresh (FreshT m) used = evalState m used
execFresh :: Fresh a -> FreshState -> FreshState
execFresh (FreshT m) used = execState m used