#ifndef MIN_VERSION_MTL
#define MIN_VERSION_MTL(x,y,z) 1
#endif
module Control.Monad.Trans.Iter
(
IterT(..)
, Iter, iter, runIter
, delay
, hoistIterT
, retract
, fold
, foldM
, MonadFree(..)
) where
import Control.Applicative
import Control.Monad (ap, liftM, MonadPlus(..))
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Control.Monad.Free.Class
import Control.Monad.State.Class
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Cont.Class
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Bind
import Data.Functor.Identity
import Data.Foldable hiding (fold)
import Data.Traversable
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Typeable
#ifdef GHC_TYPEABLE
import Data.Data
#endif
newtype IterT m a = IterT { runIterT :: m (Either a (IterT m a)) }
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#endif
type Iter = IterT Identity
iter :: Either a (Iter a) -> Iter a
iter = IterT . Identity
runIter :: Iter a -> Either a (Iter a)
runIter = runIdentity . runIterT
instance Eq (m (Either a (IterT m a))) => Eq (IterT m a) where
IterT m == IterT n = m == n
instance Ord (m (Either a (IterT m a))) => Ord (IterT m a) where
compare (IterT m) (IterT n) = compare m n
instance Show (m (Either a (IterT m a))) => Show (IterT m a) where
showsPrec d (IterT m) = showParen (d > 10) $
showString "IterT " . showsPrec 11 m
instance Read (m (Either a (IterT m a))) => Read (IterT m a) where
readsPrec d = readParen (d > 10) $ \r ->
[ (IterT m,t) | ("IterT",s) <- lex r, (m,t) <- readsPrec 11 s]
instance Monad m => Functor (IterT m) where
fmap f = IterT . liftM (bimap f (fmap f)) . runIterT
instance Monad m => Applicative (IterT m) where
pure = IterT . return . Left
(<*>) = ap
instance Monad m => Monad (IterT m) where
return = IterT . return . Left
IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k))
fail = IterT . fail
instance Monad m => Apply (IterT m) where
(<.>) = ap
instance Monad m => Bind (IterT m) where
(>>-) = (>>=)
instance MonadFix m => MonadFix (IterT m) where
mfix f = IterT $ mfix $ runIterT . f . either id (error "mfix (IterT m): Right")
instance MonadPlus m => Alternative (IterT m) where
empty = IterT mzero
IterT a <|> IterT b = IterT (mplus a b)
instance MonadPlus m => MonadPlus (IterT m) where
mzero = IterT mzero
IterT a `mplus` IterT b = IterT (mplus a b)
instance MonadTrans IterT where
lift = IterT . liftM Left
instance Foldable m => Foldable (IterT m) where
foldMap f = foldMap (either f (foldMap f)) . runIterT
instance Foldable1 m => Foldable1 (IterT m) where
foldMap1 f = foldMap1 (either f (foldMap1 f)) . runIterT
instance (Monad m, Traversable m) => Traversable (IterT m) where
traverse f (IterT m) = IterT <$> traverse (bitraverse f (traverse f)) m
instance (Monad m, Traversable1 m) => Traversable1 (IterT m) where
traverse1 f (IterT m) = IterT <$> traverse1 go m where
go (Left a) = Left <$> f a
go (Right a) = Right <$> traverse1 f a
instance (Functor m, MonadReader e m) => MonadReader e (IterT m) where
ask = lift ask
local f = hoistIterT (local f)
instance (Functor m, MonadState s m) => MonadState s (IterT m) where
get = lift get
put s = lift (put s)
#if MIN_VERSION_mtl(2,1,1)
state f = lift (state f)
#endif
instance (Functor m, MonadError e m) => MonadError e (IterT m) where
throwError = lift . throwError
IterT m `catchError` f = IterT $ (liftM (fmap (`catchError` f)) m) `catchError` (runIterT . f)
instance (Functor m, MonadIO m) => MonadIO (IterT m) where
liftIO = lift . liftIO
instance (MonadCont m) => MonadCont (IterT m) where
callCC f = IterT $ callCC (\k -> runIterT $ f (lift . k . Left))
instance Monad m => MonadFree Identity (IterT m) where
wrap = IterT . return . Right . runIdentity
delay :: (Monad f, MonadFree f m) => m a -> m a
delay = wrap . return
retract :: Monad m => IterT m a -> m a
retract m = runIterT m >>= either return retract
fold :: Monad m => (m a -> a) -> IterT m a -> a
fold phi (IterT m) = phi (either id (fold phi) `liftM` m)
foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a
foldM phi (IterT m) = phi (either return (foldM phi) `liftM` m)
hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT f (IterT as) = IterT (fmap (hoistIterT f) `liftM` f as)
#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707
instance Typeable1 m => Typeable1 (IterT m) where
typeOf1 t = mkTyConApp freeTyCon [typeOf1 (f t)] where
f :: IterT m a -> m a
f = undefined
freeTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
freeTyCon = mkTyCon "Control.Monad.Iter.IterT"
#else
freeTyCon = mkTyCon3 "free" "Control.Monad.Iter" "IterT"
#endif
instance
( Typeable1 m, Typeable a
, Data (m (Either a (IterT m a)))
, Data a
) => Data (IterT m a) where
gfoldl f z (IterT as) = z IterT `f` as
toConstr IterT{} = iterConstr
gunfold k z c = case constrIndex c of
1 -> k (z IterT)
_ -> error "gunfold"
dataTypeOf _ = iterDataType
dataCast1 f = gcast1 f
iterConstr :: Constr
iterConstr = mkConstr iterDataType "IterT" [] Prefix
iterDataType :: DataType
iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr]
#endif