{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Monad.Label where
import Control.Applicative (Applicative(pure, (<*>)), Alternative, )
import Control.Monad (MonadPlus, ap, )
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO, )
import Control.Monad.Trans.Class (MonadTrans, )
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (Reader, ReaderT(ReaderT), runReader, runReaderT, )
newtype Label l a = Label { runLabelPriv :: Reader [l] a }
deriving (Functor, Monad, MonadFix)
instance Applicative (Label l) where
pure = return
(<*>) = ap
runLabel :: Label l a -> [l] -> a
runLabel = runReader . runLabelPriv
ask :: Label l [l]
ask = Label Reader.ask
local :: l -> Label l a -> Label l a
local l m = Label $ Reader.local (l:) $ runLabelPriv m
newtype LabelT l m a = LabelT { runLabelPrivT :: ReaderT [l] m a }
deriving (Alternative, Monad, MonadPlus, MonadFix, MonadTrans, MonadIO)
fmapReaderT :: (Functor f) =>
(a -> b) -> ReaderT r f a -> ReaderT r f b
fmapReaderT f m = ReaderT $ \l -> fmap f $ runReaderT m l
instance (Functor m) => Functor (LabelT l m) where
fmap f m = LabelT $ fmapReaderT f $ runLabelPrivT m
pureReaderT :: (Applicative f) =>
a -> ReaderT r f a
pureReaderT a = ReaderT $ const $ pure a
apReaderT :: (Applicative f) =>
ReaderT r f (a -> b) ->
ReaderT r f a ->
ReaderT r f b
apReaderT f x = ReaderT $ \r -> runReaderT f r <*> runReaderT x r
instance Applicative m => Applicative (LabelT l m) where
pure a = LabelT $ pureReaderT a
f <*> x = LabelT $ runLabelPrivT f `apReaderT` runLabelPrivT x
runLabelT :: Monad m => LabelT l m a -> [l] -> m a
runLabelT = runReaderT . runLabelPrivT
askT :: Monad m => LabelT l m [l]
askT = LabelT Reader.ask
localT :: Monad m => l -> LabelT l m a -> LabelT l m a
localT l m = LabelT $ Reader.local (l:) $ runLabelPrivT m