-- |
-- A class for monads supporting a supply of fresh names
--

module Control.Monad.Supply.Class where

import Prelude.Compat

import Control.Monad.Supply
import Control.Monad.State
import Control.Monad.Writer
import Data.Text (Text, pack)

class Monad m => MonadSupply m where
  fresh :: m Integer
  peek :: m Integer
  default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer
  fresh = n Integer -> t n Integer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift n Integer
forall (m :: * -> *). MonadSupply m => m Integer
fresh
  default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer
  peek = n Integer -> t n Integer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift n Integer
forall (m :: * -> *). MonadSupply m => m Integer
peek

instance Monad m => MonadSupply (SupplyT m) where
  fresh :: SupplyT m Integer
fresh = StateT Integer m Integer -> SupplyT m Integer
forall (m :: * -> *) a. StateT Integer m a -> SupplyT m a
SupplyT (StateT Integer m Integer -> SupplyT m Integer)
-> StateT Integer m Integer -> SupplyT m Integer
forall a b. (a -> b) -> a -> b
$ do
    Integer
n <- StateT Integer m Integer
forall s (m :: * -> *). MonadState s m => m s
get
    Integer -> StateT Integer m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
    Integer -> StateT Integer m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
  peek :: SupplyT m Integer
peek = StateT Integer m Integer -> SupplyT m Integer
forall (m :: * -> *) a. StateT Integer m a -> SupplyT m a
SupplyT StateT Integer m Integer
forall s (m :: * -> *). MonadState s m => m s
get

instance MonadSupply m => MonadSupply (StateT s m)
instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m)

freshName :: MonadSupply m => m Text
freshName :: m Text
freshName = (Integer -> Text) -> m Integer -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ) (Text -> Text) -> (Integer -> Text) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) m Integer
forall (m :: * -> *). MonadSupply m => m Integer
fresh