module Control.Monad.Label where
import qualified Data.Map as M
import Control.Applicative hiding (empty)
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Reader
class (Applicative m, Monad m) => MonadLabel k l m where
label :: k -> m l
instance (MonadLabel k l m) => MonadLabel k l (StateT s m) where
label = lift . label
instance (MonadLabel k l m) => MonadLabel k l (ReaderT r m) where
label = lift . label
newtype ConsistentLabelsT k l m a = ConsistentLabelsT {
unConsistentLabelsT :: StateT ([l], M.Map k l) m a
}
deriving( Functor, Applicative, Monad, MonadTrans )
instance (Ord k, Applicative m, Monad m) => MonadLabel k l (ConsistentLabelsT k l m) where
label k = ConsistentLabelsT $ do
(ls, labelMap) <- get
case M.lookup k labelMap of
Just i -> return i
Nothing -> case ls of
[] -> error "ConsistentLabelsT: label: no more labels left."
(l:ls') -> do put (ls', M.insert k l labelMap)
return l
runConsistentLabelsT :: ConsistentLabelsT k l m a -> [l] -> m (a, ([l], M.Map k l))
runConsistentLabelsT m labels = runStateT (unConsistentLabelsT m) (labels, M.empty)
evalConsistentLabelsT :: Functor m => ConsistentLabelsT k l m a -> [l] -> m a
evalConsistentLabelsT m labels = fst <$> runConsistentLabelsT m labels
execConsistentLabelsT :: Functor m => ConsistentLabelsT k l m a -> [l] -> m ([l], M.Map k l)
execConsistentLabelsT m labels = snd <$> runConsistentLabelsT m labels
type ConsistentLabels k l = ConsistentLabelsT k l Identity
runConsistentLabels :: ConsistentLabels k l a -> [l] -> (a, ([l], M.Map k l))
runConsistentLabels m = runIdentity . runConsistentLabelsT m
evalConsistentLabels :: ConsistentLabels k l a -> [l] -> a
evalConsistentLabels m = fst . runConsistentLabels m
execConsistentLabels :: ConsistentLabels k l a -> [l] -> ([l], M.Map k l)
execConsistentLabels m = snd . runConsistentLabels m