#ifndef MIN_VERSION_MTL
#define MIN_VERSION_MTL(x,y,z) 1
#endif
module Control.Monad.Trans.Iter
( MonadFree(..)
, IterF(..)
, IterT(..)
, delay
, retract
, iter
, hoistIterT
) 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.Reader.Class
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Bind
import Data.Functor.Identity
import Data.Foldable
import Data.Monoid
import Data.Traversable
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Typeable
#ifdef GHC_TYPEABLE
import Data.Data
#endif
data IterF a b = Pure a | Iter b
deriving (Eq,Ord,Show,Read,Typeable)
instance Functor (IterF a) where
fmap _ (Pure a) = Pure a
fmap f (Iter b) = Iter (f b)
instance Foldable (IterF a) where
foldMap f (Iter b) = f b
foldMap _ _ = mempty
instance Traversable (IterF a) where
traverse _ (Pure a) = pure (Pure a)
traverse f (Iter b) = Iter <$> f b
instance Bifunctor IterF where
bimap f _ (Pure a) = Pure (f a)
bimap _ g (Iter b) = Iter (g b)
instance Bifoldable IterF where
bifoldMap f _ (Pure a) = f a
bifoldMap _ g (Iter b) = g b
instance Bitraversable IterF where
bitraverse f _ (Pure a) = Pure <$> f a
bitraverse _ g (Iter b) = Iter <$> g b
iterF :: (a -> r) -> (b -> r) -> IterF a b -> r
iterF f _ (Pure a) = f a
iterF _ g (Iter b) = g b
data IterT m a = IterT { runIterT :: m (IterF a (IterT m a)) }
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#endif
instance Eq (m (IterF a (IterT m a))) => Eq (IterT m a) where
IterT m == IterT n = m == n
instance Ord (m (IterF a (IterT m a))) => Ord (IterT m a) where
compare (IterT m) (IterT n) = compare m n
instance Show (m (IterF a (IterT m a))) => Show (IterT m a) where
showsPrec d (IterT m) = showParen (d > 10) $
showString "IterT " . showsPrec 11 m
instance Read (m (IterF 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 . Pure
(<*>) = ap
instance Monad m => Monad (IterT m) where
return = IterT . return . Pure
IterT m >>= k = IterT $ m >>= iterF (runIterT . k) (return . Iter . (>>= 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 . unPure) where
unPure (Pure x) = x
unPure (Iter _) = error "mfix (IterT m): Iter"
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 Pure
instance Foldable m => Foldable (IterT m) where
foldMap f = foldMap (iterF f (foldMap f)) . runIterT
instance Foldable1 m => Foldable1 (IterT m) where
foldMap1 f = foldMap1 (iterF 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 (Pure a) = Pure <$> f a
go (Iter a) = Iter <$> 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 Monad m => MonadFree Identity (IterT m) where
wrap = IterT . return . Iter . 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 >>= iterF return retract
iter :: Monad m => (m a -> a) -> IterT m a -> a
iter phi (IterT m) = phi (iterF id (iter 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 (IterF 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