{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- |
Here we implement a special Reader monad
that can be used to manage a call stack.
This way you can generate exception messages like
\"Corrupt file content encountered
while reading file \'foo.txt\'
while loading document \'bar.doc\'\"
using the functions in "Control.Monad.Exception.Label".

However, currently I believe that this datatype is unnecessary,
since you can extend exceptions by context information
using 'Control.Monad.Exception.Synchronous.mapException'.
-}
module Control.Monad.Label where

import Control.Applicative (Applicative(pure, (<*>)), Alternative, )

import Control.Monad (MonadPlus, )
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, )


-- * Plain monad

newtype Label l a = Label { forall l a. Label l a -> Reader [l] a
runLabelPriv :: Reader [l] a }
-- newtype Label l a = Label { runLabelPriv :: [l] -> a }
   deriving ((forall a b. (a -> b) -> Label l a -> Label l b)
-> (forall a b. a -> Label l b -> Label l a) -> Functor (Label l)
forall a b. a -> Label l b -> Label l a
forall a b. (a -> b) -> Label l a -> Label l b
forall l a b. a -> Label l b -> Label l a
forall l a b. (a -> b) -> Label l a -> Label l b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall l a b. (a -> b) -> Label l a -> Label l b
fmap :: forall a b. (a -> b) -> Label l a -> Label l b
$c<$ :: forall l a b. a -> Label l b -> Label l a
<$ :: forall a b. a -> Label l b -> Label l a
Functor, Functor (Label l)
Functor (Label l) =>
(forall a. a -> Label l a)
-> (forall a b. Label l (a -> b) -> Label l a -> Label l b)
-> (forall a b c.
    (a -> b -> c) -> Label l a -> Label l b -> Label l c)
-> (forall a b. Label l a -> Label l b -> Label l b)
-> (forall a b. Label l a -> Label l b -> Label l a)
-> Applicative (Label l)
forall l. Functor (Label l)
forall a. a -> Label l a
forall l a. a -> Label l a
forall a b. Label l a -> Label l b -> Label l a
forall a b. Label l a -> Label l b -> Label l b
forall a b. Label l (a -> b) -> Label l a -> Label l b
forall l a b. Label l a -> Label l b -> Label l a
forall l a b. Label l a -> Label l b -> Label l b
forall l a b. Label l (a -> b) -> Label l a -> Label l b
forall a b c. (a -> b -> c) -> Label l a -> Label l b -> Label l c
forall l a b c.
(a -> b -> c) -> Label l a -> Label l b -> Label l c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall l a. a -> Label l a
pure :: forall a. a -> Label l a
$c<*> :: forall l a b. Label l (a -> b) -> Label l a -> Label l b
<*> :: forall a b. Label l (a -> b) -> Label l a -> Label l b
$cliftA2 :: forall l a b c.
(a -> b -> c) -> Label l a -> Label l b -> Label l c
liftA2 :: forall a b c. (a -> b -> c) -> Label l a -> Label l b -> Label l c
$c*> :: forall l a b. Label l a -> Label l b -> Label l b
*> :: forall a b. Label l a -> Label l b -> Label l b
$c<* :: forall l a b. Label l a -> Label l b -> Label l a
<* :: forall a b. Label l a -> Label l b -> Label l a
Applicative, Applicative (Label l)
Applicative (Label l) =>
(forall a b. Label l a -> (a -> Label l b) -> Label l b)
-> (forall a b. Label l a -> Label l b -> Label l b)
-> (forall a. a -> Label l a)
-> Monad (Label l)
forall l. Applicative (Label l)
forall a. a -> Label l a
forall l a. a -> Label l a
forall a b. Label l a -> Label l b -> Label l b
forall a b. Label l a -> (a -> Label l b) -> Label l b
forall l a b. Label l a -> Label l b -> Label l b
forall l a b. Label l a -> (a -> Label l b) -> Label l b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall l a b. Label l a -> (a -> Label l b) -> Label l b
>>= :: forall a b. Label l a -> (a -> Label l b) -> Label l b
$c>> :: forall l a b. Label l a -> Label l b -> Label l b
>> :: forall a b. Label l a -> Label l b -> Label l b
$creturn :: forall l a. a -> Label l a
return :: forall a. a -> Label l a
Monad, Monad (Label l)
Monad (Label l) =>
(forall a. (a -> Label l a) -> Label l a) -> MonadFix (Label l)
forall l. Monad (Label l)
forall a. (a -> Label l a) -> Label l a
forall l a. (a -> Label l a) -> Label l a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall l a. (a -> Label l a) -> Label l a
mfix :: forall a. (a -> Label l a) -> Label l a
MonadFix)

{-
instance Functor (Label l) where
   fmap f m = Label $ \l -> f (runLabelPriv m l)

instance Applicative (Label l) where
   pure  = return
   (<*>) = ap

instance Monad (Label l) where
   return a = Label $ \_ -> a
   m >>= k  = Label $ \l -> runLabelPriv (k (runLabelPriv m l)) l

instance MonadFix (Label l) where
   mfix f = Label $ \l -> let a = runLabelPriv (f a) l in a
-}


runLabel :: Label l a -> [l] -> a
runLabel :: forall l a. Label l a -> [l] -> a
runLabel = Reader [l] a -> [l] -> a
forall r a. Reader r a -> r -> a
runReader (Reader [l] a -> [l] -> a)
-> (Label l a -> Reader [l] a) -> Label l a -> [l] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label l a -> Reader [l] a
forall l a. Label l a -> Reader [l] a
runLabelPriv

ask :: Label l [l]
ask :: forall l. Label l [l]
ask = Reader [l] [l] -> Label l [l]
forall l a. Reader [l] a -> Label l a
Label Reader [l] [l]
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask
-- ask = Label id

local :: l -> Label l a -> Label l a
local :: forall l a. l -> Label l a -> Label l a
local l
l Label l a
m = Reader [l] a -> Label l a
forall l a. Reader [l] a -> Label l a
Label (Reader [l] a -> Label l a) -> Reader [l] a -> Label l a
forall a b. (a -> b) -> a -> b
$ ([l] -> [l]) -> Reader [l] a -> Reader [l] a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
Reader.local (l
ll -> [l] -> [l]
forall a. a -> [a] -> [a]
:) (Reader [l] a -> Reader [l] a) -> Reader [l] a -> Reader [l] a
forall a b. (a -> b) -> a -> b
$ Label l a -> Reader [l] a
forall l a. Label l a -> Reader [l] a
runLabelPriv Label l a
m
-- local l m = Label $ runLabelPriv m . (l:)




-- * Monad transformer


newtype LabelT l m a = LabelT { forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT :: ReaderT [l] m a }
-- newtype LabelT l m a = LabelT { runLabelPrivT :: l -> m a }
   deriving (Applicative (LabelT l m)
Applicative (LabelT l m) =>
(forall a. LabelT l m a)
-> (forall a. LabelT l m a -> LabelT l m a -> LabelT l m a)
-> (forall a. LabelT l m a -> LabelT l m [a])
-> (forall a. LabelT l m a -> LabelT l m [a])
-> Alternative (LabelT l m)
forall a. LabelT l m a
forall a. LabelT l m a -> LabelT l m [a]
forall a. LabelT l m a -> LabelT l m a -> LabelT l m a
forall l (m :: * -> *). Alternative m => Applicative (LabelT l m)
forall l (m :: * -> *) a. Alternative m => LabelT l m a
forall l (m :: * -> *) a.
Alternative m =>
LabelT l m a -> LabelT l m [a]
forall l (m :: * -> *) a.
Alternative m =>
LabelT l m a -> LabelT l m a -> LabelT l m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall l (m :: * -> *) a. Alternative m => LabelT l m a
empty :: forall a. LabelT l m a
$c<|> :: forall l (m :: * -> *) a.
Alternative m =>
LabelT l m a -> LabelT l m a -> LabelT l m a
<|> :: forall a. LabelT l m a -> LabelT l m a -> LabelT l m a
$csome :: forall l (m :: * -> *) a.
Alternative m =>
LabelT l m a -> LabelT l m [a]
some :: forall a. LabelT l m a -> LabelT l m [a]
$cmany :: forall l (m :: * -> *) a.
Alternative m =>
LabelT l m a -> LabelT l m [a]
many :: forall a. LabelT l m a -> LabelT l m [a]
Alternative, Applicative (LabelT l m)
Applicative (LabelT l m) =>
(forall a b. LabelT l m a -> (a -> LabelT l m b) -> LabelT l m b)
-> (forall a b. LabelT l m a -> LabelT l m b -> LabelT l m b)
-> (forall a. a -> LabelT l m a)
-> Monad (LabelT l m)
forall a. a -> LabelT l m a
forall a b. LabelT l m a -> LabelT l m b -> LabelT l m b
forall a b. LabelT l m a -> (a -> LabelT l m b) -> LabelT l m b
forall l (m :: * -> *). Monad m => Applicative (LabelT l m)
forall l (m :: * -> *) a. Monad m => a -> LabelT l m a
forall l (m :: * -> *) a b.
Monad m =>
LabelT l m a -> LabelT l m b -> LabelT l m b
forall l (m :: * -> *) a b.
Monad m =>
LabelT l m a -> (a -> LabelT l m b) -> LabelT l m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall l (m :: * -> *) a b.
Monad m =>
LabelT l m a -> (a -> LabelT l m b) -> LabelT l m b
>>= :: forall a b. LabelT l m a -> (a -> LabelT l m b) -> LabelT l m b
$c>> :: forall l (m :: * -> *) a b.
Monad m =>
LabelT l m a -> LabelT l m b -> LabelT l m b
>> :: forall a b. LabelT l m a -> LabelT l m b -> LabelT l m b
$creturn :: forall l (m :: * -> *) a. Monad m => a -> LabelT l m a
return :: forall a. a -> LabelT l m a
Monad, Monad (LabelT l m)
Alternative (LabelT l m)
(Alternative (LabelT l m), Monad (LabelT l m)) =>
(forall a. LabelT l m a)
-> (forall a. LabelT l m a -> LabelT l m a -> LabelT l m a)
-> MonadPlus (LabelT l m)
forall a. LabelT l m a
forall a. LabelT l m a -> LabelT l m a -> LabelT l m a
forall l (m :: * -> *). MonadPlus m => Monad (LabelT l m)
forall l (m :: * -> *). MonadPlus m => Alternative (LabelT l m)
forall l (m :: * -> *) a. MonadPlus m => LabelT l m a
forall l (m :: * -> *) a.
MonadPlus m =>
LabelT l m a -> LabelT l m a -> LabelT l m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall l (m :: * -> *) a. MonadPlus m => LabelT l m a
mzero :: forall a. LabelT l m a
$cmplus :: forall l (m :: * -> *) a.
MonadPlus m =>
LabelT l m a -> LabelT l m a -> LabelT l m a
mplus :: forall a. LabelT l m a -> LabelT l m a -> LabelT l m a
MonadPlus, Monad (LabelT l m)
Monad (LabelT l m) =>
(forall a. (a -> LabelT l m a) -> LabelT l m a)
-> MonadFix (LabelT l m)
forall a. (a -> LabelT l m a) -> LabelT l m a
forall l (m :: * -> *). MonadFix m => Monad (LabelT l m)
forall l (m :: * -> *) a.
MonadFix m =>
(a -> LabelT l m a) -> LabelT l m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall l (m :: * -> *) a.
MonadFix m =>
(a -> LabelT l m a) -> LabelT l m a
mfix :: forall a. (a -> LabelT l m a) -> LabelT l m a
MonadFix, (forall (m :: * -> *). Monad m => Monad (LabelT l m)) =>
(forall (m :: * -> *) a. Monad m => m a -> LabelT l m a)
-> MonadTrans (LabelT l)
forall l (m :: * -> *). Monad m => Monad (LabelT l m)
forall l (m :: * -> *) a. Monad m => m a -> LabelT l m a
forall (m :: * -> *). Monad m => Monad (LabelT l m)
forall (m :: * -> *) a. Monad m => m a -> LabelT l m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall l (m :: * -> *) a. Monad m => m a -> LabelT l m a
lift :: forall (m :: * -> *) a. Monad m => m a -> LabelT l m a
MonadTrans, Monad (LabelT l m)
Monad (LabelT l m) =>
(forall a. IO a -> LabelT l m a) -> MonadIO (LabelT l m)
forall a. IO a -> LabelT l m a
forall l (m :: * -> *). MonadIO m => Monad (LabelT l m)
forall l (m :: * -> *) a. MonadIO m => IO a -> LabelT l m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall l (m :: * -> *) a. MonadIO m => IO a -> LabelT l m a
liftIO :: forall a. IO a -> LabelT l m a
MonadIO)

{-
instance (Monad m) => Functor (LabelT l m) where
   fmap f m = LabelT $ \l -> do
      a <- runLabelPrivT m l
      return (f a)

instance (Monad m) => Monad (LabelT l m) where
   return a = LabelT $ \_ -> return a
   m >>= k  = LabelT $ \l -> do
      a <- runLabelPrivT m l
      runLabelPrivT (k a) l
   fail msg = LabelT $ \_ -> fail msg

instance (MonadPlus m) => MonadPlus (LabelT l m) where
   mzero       = LabelT $ \_ -> mzero
   m `mplus` n = LabelT $ \l -> runLabelPrivT m l `mplus` runLabelPrivT n l

instance (MonadFix m) => MonadFix (LabelT l m) where
   mfix f = LabelT $ \l -> mfix $ \a -> runLabelPrivT (f a) l

instance MonadTrans (LabelT l) where
   lift m = LabelT $ \_ -> m

instance (MonadIO m) => MonadIO (LabelT l m) where
   liftIO = lift . liftIO
-}

{-
instance Monad m => Applicative (LabelT l m) where
   pure = return
   (<*>) = ap
-}


fmapReaderT :: (Functor f) =>
   (a -> b) -> ReaderT r f a -> ReaderT r f b
fmapReaderT :: forall (f :: * -> *) a b r.
Functor f =>
(a -> b) -> ReaderT r f a -> ReaderT r f b
fmapReaderT a -> b
f ReaderT r f a
m = (r -> f b) -> ReaderT r f b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> f b) -> ReaderT r f b) -> (r -> f b) -> ReaderT r f b
forall a b. (a -> b) -> a -> b
$ \r
l -> (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (f a -> f b) -> f a -> f b
forall a b. (a -> b) -> a -> b
$ ReaderT r f a -> r -> f a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r f a
m r
l

instance (Functor m) => Functor (LabelT l m) where
   fmap :: forall a b. (a -> b) -> LabelT l m a -> LabelT l m b
fmap a -> b
f LabelT l m a
m = ReaderT [l] m b -> LabelT l m b
forall l (m :: * -> *) a. ReaderT [l] m a -> LabelT l m a
LabelT (ReaderT [l] m b -> LabelT l m b)
-> ReaderT [l] m b -> LabelT l m b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ReaderT [l] m a -> ReaderT [l] m b
forall (f :: * -> *) a b r.
Functor f =>
(a -> b) -> ReaderT r f a -> ReaderT r f b
fmapReaderT a -> b
f (ReaderT [l] m a -> ReaderT [l] m b)
-> ReaderT [l] m a -> ReaderT [l] m b
forall a b. (a -> b) -> a -> b
$ LabelT l m a -> ReaderT [l] m a
forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT LabelT l m a
m


pureReaderT :: (Applicative f) =>
   a -> ReaderT r f a
pureReaderT :: forall (f :: * -> *) a r. Applicative f => a -> ReaderT r f a
pureReaderT a
a = (r -> f a) -> ReaderT r f a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> f a) -> ReaderT r f a) -> (r -> f a) -> ReaderT r f a
forall a b. (a -> b) -> a -> b
$ f a -> r -> f a
forall a b. a -> b -> a
const (f a -> r -> f a) -> f a -> r -> f a
forall a b. (a -> b) -> a -> b
$ a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

apReaderT :: (Applicative f) =>
   ReaderT r f (a -> b) ->
   ReaderT r f a ->
   ReaderT r f b
apReaderT :: forall (f :: * -> *) r a b.
Applicative f =>
ReaderT r f (a -> b) -> ReaderT r f a -> ReaderT r f b
apReaderT ReaderT r f (a -> b)
f ReaderT r f a
x = (r -> f b) -> ReaderT r f b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> f b) -> ReaderT r f b) -> (r -> f b) -> ReaderT r f b
forall a b. (a -> b) -> a -> b
$ \r
r -> ReaderT r f (a -> b) -> r -> f (a -> b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r f (a -> b)
f r
r f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT r f a -> r -> f a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r f a
x r
r

instance Applicative m => Applicative (LabelT l m) where
   pure :: forall a. a -> LabelT l m a
pure a
a  = ReaderT [l] m a -> LabelT l m a
forall l (m :: * -> *) a. ReaderT [l] m a -> LabelT l m a
LabelT (ReaderT [l] m a -> LabelT l m a)
-> ReaderT [l] m a -> LabelT l m a
forall a b. (a -> b) -> a -> b
$ a -> ReaderT [l] m a
forall (f :: * -> *) a r. Applicative f => a -> ReaderT r f a
pureReaderT a
a
   LabelT l m (a -> b)
f <*> :: forall a b. LabelT l m (a -> b) -> LabelT l m a -> LabelT l m b
<*> LabelT l m a
x = ReaderT [l] m b -> LabelT l m b
forall l (m :: * -> *) a. ReaderT [l] m a -> LabelT l m a
LabelT (ReaderT [l] m b -> LabelT l m b)
-> ReaderT [l] m b -> LabelT l m b
forall a b. (a -> b) -> a -> b
$ LabelT l m (a -> b) -> ReaderT [l] m (a -> b)
forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT LabelT l m (a -> b)
f ReaderT [l] m (a -> b) -> ReaderT [l] m a -> ReaderT [l] m b
forall (f :: * -> *) r a b.
Applicative f =>
ReaderT r f (a -> b) -> ReaderT r f a -> ReaderT r f b
`apReaderT` LabelT l m a -> ReaderT [l] m a
forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT LabelT l m a
x


runLabelT :: Monad m => LabelT l m a -> [l] -> m a
runLabelT :: forall (m :: * -> *) l a. Monad m => LabelT l m a -> [l] -> m a
runLabelT = ReaderT [l] m a -> [l] -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT [l] m a -> [l] -> m a)
-> (LabelT l m a -> ReaderT [l] m a) -> LabelT l m a -> [l] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelT l m a -> ReaderT [l] m a
forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT

askT :: Monad m => LabelT l m [l]
askT :: forall (m :: * -> *) l. Monad m => LabelT l m [l]
askT = ReaderT [l] m [l] -> LabelT l m [l]
forall l (m :: * -> *) a. ReaderT [l] m a -> LabelT l m a
LabelT ReaderT [l] m [l]
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask

localT :: Monad m => l -> LabelT l m a -> LabelT l m a
localT :: forall (m :: * -> *) l a.
Monad m =>
l -> LabelT l m a -> LabelT l m a
localT l
l LabelT l m a
m = ReaderT [l] m a -> LabelT l m a
forall l (m :: * -> *) a. ReaderT [l] m a -> LabelT l m a
LabelT (ReaderT [l] m a -> LabelT l m a)
-> ReaderT [l] m a -> LabelT l m a
forall a b. (a -> b) -> a -> b
$ ([l] -> [l]) -> ReaderT [l] m a -> ReaderT [l] m a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
Reader.local (l
ll -> [l] -> [l]
forall a. a -> [a] -> [a]
:) (ReaderT [l] m a -> ReaderT [l] m a)
-> ReaderT [l] m a -> ReaderT [l] m a
forall a b. (a -> b) -> a -> b
$ LabelT l m a -> ReaderT [l] m a
forall l (m :: * -> *) a. LabelT l m a -> ReaderT [l] m a
runLabelPrivT LabelT l m a
m