{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.Iter
-- Copyright   :  (C) 2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- Based on <http://www.ioc.ee/~tarmo/tday-veskisilla/uustalu-slides.pdf Capretta's Iterative Monad Transformer>
--
-- Unlike 'Free', this is a true monad transformer.
----------------------------------------------------------------------------
module Control.Monad.Trans.Iter
  (
  -- |
  -- Functions in Haskell are meant to be pure. For example, if an expression
  -- has type Int, there should exist a value of the type such that the expression
  -- can be replaced by that value in any context without changing the meaning
  -- of the program.
  --
  -- Some computations may perform side effects (@unsafePerformIO@), throw an
  -- exception (using @error@); or not terminate
  -- (@let infinity = 1 + infinity in infinity@).
  --
  -- While the 'IO' monad encapsulates side-effects, and the 'Either'
  -- monad encapsulates errors, the 'Iter' monad encapsulates
  -- non-termination. The 'IterT' transformer generalizes non-termination to any monadic
  -- computation.
  --
  -- Computations in 'IterT' (or 'Iter') can be composed in two ways:
  --
  -- * /Sequential:/ Using the 'Monad' instance, the result of a computation
  --   can be fed into the next.
  --
  -- * /Parallel:/ Using the 'MonadPlus' instance, several computations can be
  --   executed concurrently, and the first to finish will prevail.
  --   See also the <examples/Cabbage.lhs cabbage example>.

  -- * The iterative monad transformer
    IterT(..)
  -- * Capretta's iterative monad
  , Iter, iter, runIter
  -- * Combinators
  , delay
  , hoistIterT
  , liftIter
  , cutoff
  , never
  , untilJust
  , interleave, interleave_
  -- * Consuming iterative monads
  , retract
  , fold
  , foldM
  -- * IterT ~ FreeT Identity
  , MonadFree(..)
  -- * Examples
  -- $examples
  ) where

import Control.Applicative
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Monad (ap, liftM, MonadPlus(..), join)
import Control.Monad.Fix
import Control.Monad.Trans.Class
import qualified Control.Monad.Fail as Fail
import Control.Monad.Free.Class
import Control.Monad.State.Class
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.Cont.Class
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.Bitraversable
import Data.Either
import Data.Functor.Bind hiding (join)
import Data.Functor.Classes
import Data.Functor.Identity
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Typeable
import Data.Data

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif

-- | The monad supporting iteration based over a base monad @m@.
--
-- @
-- 'IterT' ~ 'FreeT' 'Identity'
-- @
newtype IterT m a = IterT { forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT :: m (Either a (IterT m a)) }

-- | Plain iterative computations.
type Iter = IterT Identity

-- | Builds an iterative computation from one first step.
--
-- prop> runIter . iter == id
iter :: Either a (Iter a) -> Iter a
iter :: forall a. Either a (Iter a) -> Iter a
iter = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity
{-# INLINE iter #-}

-- | Executes the first step of an iterative computation
--
-- prop> iter . runIter == id
runIter :: Iter a -> Either a (Iter a)
runIter :: forall a. Iter a -> Either a (Iter a)
runIter = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT
{-# INLINE runIter #-}

instance (Eq1 m) => Eq1 (IterT m) where
  liftEq :: forall a b. (a -> b -> Bool) -> IterT m a -> IterT m b -> Bool
liftEq a -> b -> Bool
eq = forall {f :: * -> *}. Eq1 f => IterT f a -> IterT f b -> Bool
go
    where
      go :: IterT f a -> IterT f b -> Bool
go (IterT f (Either a (IterT f a))
x) (IterT f (Either b (IterT f b))
y) = forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> b -> Bool
eq IterT f a -> IterT f b -> Bool
go) f (Either a (IterT f a))
x f (Either b (IterT f b))
y

instance (Eq1 m, Eq a) => Eq (IterT m a) where
  == :: IterT m a -> IterT m a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

instance (Ord1 m) => Ord1 (IterT m) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> IterT m a -> IterT m b -> Ordering
liftCompare a -> b -> Ordering
cmp = forall {f :: * -> *}. Ord1 f => IterT f a -> IterT f b -> Ordering
go
    where
      go :: IterT f a -> IterT f b -> Ordering
go (IterT f (Either a (IterT f a))
x) (IterT f (Either b (IterT f b))
y) = forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> b -> Ordering
cmp IterT f a -> IterT f b -> Ordering
go) f (Either a (IterT f a))
x f (Either b (IterT f b))
y

instance (Ord1 m, Ord a) => Ord (IterT m a) where
  compare :: IterT m a -> IterT m a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

instance (Show1 m) => Show1 (IterT m) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> IterT m a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl = Int -> IterT m a -> ShowS
go
    where
      goList :: [IterT m a] -> ShowS
goList = forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl
      go :: Int -> IterT m a -> ShowS
go Int
d (IterT m (Either a (IterT m a))
x) = forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith
        (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec (forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp [a] -> ShowS
sl Int -> IterT m a -> ShowS
go [IterT m a] -> ShowS
goList) (forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> [f a b]
-> ShowS
liftShowList2 Int -> a -> ShowS
sp [a] -> ShowS
sl Int -> IterT m a -> ShowS
go [IterT m a] -> ShowS
goList))
        String
"IterT" Int
d m (Either a (IterT m a))
x

instance (Show1 m, Show a) => Show (IterT m a) where
  showsPrec :: Int -> IterT m a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Read1 m) => Read1 (IterT m) where
  liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (IterT m a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = Int -> ReadS (IterT m a)
go
    where
      goList :: ReadS [IterT m a]
goList = forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp ReadS [a]
rl
      go :: Int -> ReadS (IterT m a)
go = forall a. (String -> ReadS a) -> Int -> ReadS a
readsData forall a b. (a -> b) -> a -> b
$ forall a t.
(Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith
        (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
rp ReadS [a]
rl Int -> ReadS (IterT m a)
go ReadS [IterT m a]
goList) (forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
liftReadList2 Int -> ReadS a
rp ReadS [a]
rl Int -> ReadS (IterT m a)
go ReadS [IterT m a]
goList))
        String
"IterT" forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT

instance (Read1 m, Read a) => Read (IterT m a) where
  readsPrec :: Int -> ReadS (IterT m a)
readsPrec = forall (f :: * -> *) a. (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1

instance Monad m => Functor (IterT m) where
  fmap :: forall a b. (a -> b) -> IterT m a -> IterT m b
fmap a -> b
f = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT
  {-# INLINE fmap #-}

instance Monad m => Applicative (IterT m) where
  pure :: forall a. a -> IterT m a
pure = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
  {-# INLINE pure #-}
  <*> :: forall a b. IterT m (a -> b) -> IterT m a -> IterT m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<*>) #-}

instance Monad m => Monad (IterT m) where
  return :: forall a. a -> IterT m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE return #-}
  IterT m (Either a (IterT m a))
m >>= :: forall a b. IterT m a -> (a -> IterT m b) -> IterT m b
>>= a -> IterT m b
k = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ m (Either a (IterT m a))
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IterT m b
k) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IterT m b
k))
  {-# INLINE (>>=) #-}
#if !MIN_VERSION_base(4,13,0)
  fail = Fail.fail
  {-# INLINE fail #-}
#endif

instance Monad m => Fail.MonadFail (IterT m) where
  fail :: forall a. String -> IterT m a
fail String
_ = forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a
never
  {-# INLINE fail #-}

instance Monad m => Apply (IterT m) where
  <.> :: forall a b. IterT m (a -> b) -> IterT m a -> IterT m b
(<.>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
  {-# INLINE (<.>) #-}

instance Monad m => Bind (IterT m) where
  >>- :: forall a b. IterT m a -> (a -> IterT m b) -> IterT m b
(>>-) = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
  {-# INLINE (>>-) #-}

instance MonadFix m => MonadFix (IterT m) where
  mfix :: forall a. (a -> IterT m a) -> IterT m a
mfix a -> IterT m a
f = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IterT m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a. HasCallStack => String -> a
error String
"mfix (IterT m): Right")
  {-# INLINE mfix #-}

instance Monad m => Alternative (IterT m) where
  empty :: forall a. IterT m a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  {-# INLINE empty #-}
  <|> :: forall a. IterT m a -> IterT m a -> IterT m a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
  {-# INLINE (<|>) #-}

-- | Capretta's 'race' combinator. Satisfies left catch.
instance Monad m => MonadPlus (IterT m) where
  mzero :: forall a. IterT m a
mzero = forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a
never
  {-# INLINE mzero #-}
  (IterT m (Either a (IterT m a))
x) mplus :: forall a. IterT m a -> IterT m a -> IterT m a
`mplus` (IterT m (Either a (IterT m a))
y) = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ m (Either a (IterT m a))
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                                (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
                                (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM m (Either a (IterT m a))
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus)
  {-# INLINE mplus #-}

instance MonadTrans IterT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> IterT m a
lift = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. a -> Either a b
Left
  {-# INLINE lift #-}

instance Foldable m => Foldable (IterT m) where
  foldMap :: forall m a. Monoid m => (a -> m) -> IterT m a -> m
foldMap a -> m
f = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m
f (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT
  {-# INLINE foldMap #-}

instance Foldable1 m => Foldable1 (IterT m) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> IterT m a -> m
foldMap1 a -> m
f = forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m
f (forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 a -> m
f)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT
  {-# INLINE foldMap1 #-}

instance (Monad m, Traversable m) => Traversable (IterT m) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IterT m a -> f (IterT m b)
traverse a -> f b
f (IterT m (Either a (IterT m a))
m) = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f b
f (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f)) m (Either a (IterT m a))
m
  {-# INLINE traverse #-}

instance (Monad m, Traversable1 m) => Traversable1 (IterT m) where
  traverse1 :: forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> IterT m a -> f (IterT m b)
traverse1 a -> f b
f (IterT m (Either a (IterT m a))
m) = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 forall {t :: * -> *}.
Traversable1 t =>
Either a (t a) -> f (Either b (t b))
go m (Either a (IterT m a))
m where
    go :: Either a (t a) -> f (Either b (t b))
go (Left a
a) = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
    go (Right t a
a) = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
traverse1 a -> f b
f t a
a
  {-# INLINE traverse1 #-}

instance MonadReader e m => MonadReader e (IterT m) where
  ask :: IterT m e
ask = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
  {-# INLINE ask #-}
  local :: forall a. (e -> e) -> IterT m a -> IterT m a
local e -> e
f = forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local e -> e
f)
  {-# INLINE local #-}

instance MonadWriter w m => MonadWriter w (IterT m) where
  tell :: w -> IterT m ()
tell = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  {-# INLINE tell #-}
  listen :: forall a. IterT m a -> IterT m (a, w)
listen (IterT m (Either a (IterT m a))
m) = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {f :: * -> *} {p :: * -> * -> *} {c} {a} {a}.
(Functor f, Bifunctor p, Monoid c) =>
(Either a (f (p a c)), c) -> Either (a, c) (f (p a c))
concat' forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Either a (IterT m a))
m)
    where
      concat' :: (Either a (f (p a c)), c) -> Either (a, c) (f (p a c))
concat' (Left  a
x, c
w) = forall a b. a -> Either a b
Left (a
x, c
w)
      concat' (Right f (p a c)
y, c
w) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (c
w forall a. Monoid a => a -> a -> a
`mappend`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (p a c)
y
  pass :: forall a. IterT m (a, w -> w) -> IterT m a
pass IterT m (a, w -> w)
m = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {t}.
m (Either ((a, t -> w), t) (IterT m ((a, t -> w), t)))
-> m (Either a (IterT m a))
pass' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT forall {a}. m a -> m a
clean forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen IterT m (a, w -> w)
m
    where
      clean :: m a -> m a
clean = forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x, forall a b. a -> b -> a
const forall a. Monoid a => a
mempty))
      pass' :: m (Either ((a, t -> w), t) (IterT m ((a, t -> w), t)))
-> m (Either a (IterT m a))
pass' = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Either ((a, t -> w), t) (IterT m ((a, t -> w), t))
-> m (Either a (IterT m a))
g
      g :: Either ((a, t -> w), t) (IterT m ((a, t -> w), t))
-> m (Either a (IterT m a))
g (Left  ((a
x, t -> w
f), t
w)) = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (t -> w
f t
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left a
x)
      g (Right IterT m ((a, t -> w), t)
f)           = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either ((a, t -> w), t) (IterT m ((a, t -> w), t)))
-> m (Either a (IterT m a))
pass' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall a b. (a -> b) -> a -> b
$ IterT m ((a, t -> w), t)
f
  writer :: forall a. (a, w) -> IterT m a
writer (a, w)
w = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer (a, w)
w)
  {-# INLINE writer #-}

instance MonadState s m => MonadState s (IterT m) where
  get :: IterT m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  {-# INLINE get #-}
  put :: s -> IterT m ()
put s
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s)
  {-# INLINE put #-}
  state :: forall a. (s -> (a, s)) -> IterT m a
state s -> (a, s)
f = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state s -> (a, s)
f)
  {-# INLINE state #-}

instance MonadError e m => MonadError e (IterT m) where
  throwError :: forall a. e -> IterT m a
throwError = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  {-# INLINE throwError #-}
  IterT m (Either a (IterT m a))
m catchError :: forall a. IterT m a -> (e -> IterT m a) -> IterT m a
`catchError` e -> IterT m a
f = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` e -> IterT m a
f)) m (Either a (IterT m a))
m forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IterT m a
f)

instance MonadIO m => MonadIO (IterT m) where
  liftIO :: forall a. IO a -> IterT m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadCont m => MonadCont (IterT m) where
  callCC :: forall a b. ((a -> IterT m b) -> IterT m a) -> IterT m a
callCC (a -> IterT m b) -> IterT m a
f = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (\Either a (IterT m a) -> m b
k -> forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall a b. (a -> b) -> a -> b
$ (a -> IterT m b) -> IterT m a
f (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a (IterT m a) -> m b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left))

instance Monad m => MonadFree Identity (IterT m) where
  wrap :: forall a. Identity (IterT m a) -> IterT m a
wrap = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity
  {-# INLINE wrap #-}

instance MonadThrow m => MonadThrow (IterT m) where
  throwM :: forall e a. Exception e => e -> IterT m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
  {-# INLINE throwM #-}

instance MonadCatch m => MonadCatch (IterT m) where
  catch :: forall e a.
Exception e =>
IterT m a -> (e -> IterT m a) -> IterT m a
catch (IterT m (Either a (IterT m a))
m) e -> IterT m a
f = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Control.Monad.Catch.catch` e -> IterT m a
f)) m (Either a (IterT m a))
m forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Control.Monad.Catch.catch` (forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IterT m a
f)
  {-# INLINE catch #-}

-- | Adds an extra layer to a free monad value.
--
-- In particular, for the iterative monad 'Iter', this makes the
-- computation require one more step, without changing its final
-- result.
--
-- prop> runIter (delay ma) == Right ma
delay :: (Monad f, MonadFree f m) => m a -> m a
delay :: forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a -> m a
delay = forall (f :: * -> *) (m :: * -> *) a.
MonadFree f m =>
f (m a) -> m a
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE delay #-}

-- |
-- 'retract' is the left inverse of 'lift'
--
-- @
-- 'retract' . 'lift' = 'id'
-- @
retract :: Monad m => IterT m a -> m a
retract :: forall (m :: * -> *) a. Monad m => IterT m a -> m a
retract IterT m a
m = forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT IterT m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a. Monad m => IterT m a -> m a
retract

-- | Tear down a 'Free' 'Monad' using iteration.
fold :: Monad m => (m a -> a) -> IterT m a -> a
fold :: forall (m :: * -> *) a. Monad m => (m a -> a) -> IterT m a -> a
fold m a -> a
phi (IterT m (Either a (IterT m a))
m) = m a -> a
phi (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall (m :: * -> *) a. Monad m => (m a -> a) -> IterT m a -> a
fold m a -> a
phi) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Either a (IterT m a))
m)

-- | Like 'fold' with monadic result.
foldM :: (Monad m, Monad n) => (m (n a) -> n a) -> IterT m a -> n a
foldM :: forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(m (n a) -> n a) -> IterT m a -> n a
foldM m (n a) -> n a
phi (IterT m (Either a (IterT m a))
m) = m (n a) -> n a
phi (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) (n :: * -> *) a.
(Monad m, Monad n) =>
(m (n a) -> n a) -> IterT m a -> n a
foldM m (n a) -> n a
phi) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Either a (IterT m a))
m)

-- | Lift a monad homomorphism from @m@ to @n@ into a Monad homomorphism from @'IterT' m@ to @'IterT' n@.
hoistIterT :: Monad n => (forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT :: forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT forall a. m a -> n a
f (IterT m (Either b (IterT m b))
as) = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT forall a. m a -> n a
f) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall a. m a -> n a
f m (Either b (IterT m b))
as)

-- | Lifts a plain, non-terminating computation into a richer environment.
-- 'liftIter' is a 'Monad' homomorphism.
liftIter :: (Monad m) => Iter a -> IterT m a
liftIter :: forall (m :: * -> *) a. Monad m => Iter a -> IterT m a
liftIter = forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> n a) -> IterT m b -> IterT n b
hoistIterT (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)

-- | A computation that never terminates
never :: (Monad f, MonadFree f m) => m a
never :: forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a
never = forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a -> m a
delay forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a
never

-- | Repeatedly run a computation until it produces a 'Just' value.
-- This can be useful when paired with a monad that has side effects.
--
-- For example, we may have @genId :: IO (Maybe Id)@ that uses a random
-- number generator to allocate ids, but fails if it finds a collision.
-- We can repeatedly run this with
--
-- @
-- 'retract' ('untilJust' genId) :: IO Id
-- @
untilJust :: (Monad m) => m (Maybe a) -> IterT m a
untilJust :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> IterT m a
untilJust m (Maybe a)
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) (m :: * -> *) a.
(Monad f, MonadFree f m) =>
m a -> m a
delay (forall (m :: * -> *) a. Monad m => m (Maybe a) -> IterT m a
untilJust m (Maybe a)
f)) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe a)
f
{-# INLINE untilJust #-}

-- | Cuts off an iterative computation after a given number of
-- steps. If the number of steps is 0 or less, no computation nor
-- monadic effects will take place.
--
-- The step where the final value is produced also counts towards the limit.
--
-- Some examples (@n ≥ 0@):
--
-- @
-- 'cutoff' 0     _        ≡ 'return' 'Nothing'
-- 'cutoff' (n+1) '.' 'return' ≡ 'return' '.' 'Just'
-- 'cutoff' (n+1) '.' 'lift'   ≡ 'lift' '.' 'liftM' 'Just'
-- 'cutoff' (n+1) '.' 'delay'  ≡ 'delay' . 'cutoff' n
-- 'cutoff' n     'never'    ≡ 'iterate' 'delay' ('return' 'Nothing') '!!' n
-- @
--
-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the
-- steps in the iteration is terminating.
cutoff :: (Monad m) => Integer -> IterT m a -> IterT m (Maybe a)
cutoff :: forall (m :: * -> *) a.
Monad m =>
Integer -> IterT m a -> IterT m (Maybe a)
cutoff Integer
n | Integer
n forall a. Ord a => a -> a -> Bool
<= Integer
0 = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
cutoff Integer
n          = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
                                       (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Monad m =>
Integer -> IterT m a -> IterT m (Maybe a)
cutoff (Integer
n forall a. Num a => a -> a -> a
- Integer
1))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT

-- | Interleaves the steps of a finite list of iterative computations, and
--   collects their results.
--
--   The resulting computation has as many steps as the longest computation
--   in the list.
interleave :: Monad m => [IterT m a] -> IterT m [a]
interleave :: forall (m :: * -> *) a. Monad m => [IterT m a] -> IterT m [a]
interleave [IterT m a]
ms = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ do
  [Either a (IterT m a)]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT [IterT m a]
ms
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a b. [Either a b] -> [b]
rights [Either a (IterT m a)]
xs)
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [a]
lefts [Either a (IterT m a)]
xs
     else forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => [IterT m a] -> IterT m [a]
interleave forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id) [Either a (IterT m a)]
xs
{-# INLINE interleave #-}

-- | Interleaves the steps of a finite list of computations, and discards their
--   results.
--
--   The resulting computation has as many steps as the longest computation
--   in the list.
--
--   Equivalent to @'void' '.' 'interleave'@.
interleave_ :: (Monad m) => [IterT m a] -> IterT m ()
interleave_ :: forall (m :: * -> *) a. Monad m => [IterT m a] -> IterT m ()
interleave_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
interleave_ [IterT m a]
xs = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => [IterT m a] -> IterT m ()
interleave_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT [IterT m a]
xs
{-# INLINE interleave_ #-}

instance (Monad m, Semigroup a, Monoid a) => Monoid (IterT m a) where
  mempty :: IterT m a
mempty = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  mappend :: IterT m a -> IterT m a -> IterT m a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mconcat :: [IterT m a] -> IterT m a
mconcat = forall (m :: * -> *) a.
(Monad m, Monoid a) =>
[Either a (IterT m a)] -> IterT m a
mconcat' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right
    where
      mconcat' :: (Monad m, Monoid a) => [Either a (IterT m a)] -> IterT m a
      mconcat' :: forall (m :: * -> *) a.
(Monad m, Monoid a) =>
[Either a (IterT m a)] -> IterT m a
mconcat' [Either a (IterT m a)]
ms = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ do
        [Either a (IterT m a)]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT) [Either a (IterT m a)]
ms
        case forall a b. Monoid a => [Either a b] -> [Either a b]
compact [Either a (IterT m a)]
xs of
          [l :: Either a (IterT m a)
l@(Left a
_)] -> forall (m :: * -> *) a. Monad m => a -> m a
return Either a (IterT m a)
l
          [Either a (IterT m a)]
xs' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, Monoid a) =>
[Either a (IterT m a)] -> IterT m a
mconcat' [Either a (IterT m a)]
xs'
      {-# INLINE mconcat' #-}

      compact :: (Monoid a) => [Either a b] -> [Either a b]
      compact :: forall a b. Monoid a => [Either a b] -> [Either a b]
compact []               = []
      compact (r :: Either a b
r@(Right b
_):[Either a b]
xs) = Either a b
rforall a. a -> [a] -> [a]
:(forall a b. Monoid a => [Either a b] -> [Either a b]
compact [Either a b]
xs)
      compact (   Left a
a  :[Either a b]
xs)  = forall {t} {b}. Monoid t => t -> [Either t b] -> [Either t b]
compact' a
a [Either a b]
xs

      compact' :: t -> [Either t b] -> [Either t b]
compact' t
a []               = [forall a b. a -> Either a b
Left t
a]
      compact' t
a (r :: Either t b
r@(Right b
_):[Either t b]
xs) = (forall a b. a -> Either a b
Left t
a)forall a. a -> [a] -> [a]
:(Either t b
rforall a. a -> [a] -> [a]
:(forall a b. Monoid a => [Either a b] -> [Either a b]
compact [Either t b]
xs))
      compact' t
a (  (Left t
a'):[Either t b]
xs) = t -> [Either t b] -> [Either t b]
compact' (t
a forall a. Monoid a => a -> a -> a
`mappend` t
a') [Either t b]
xs

instance (Monad m, Semigroup a) => Semigroup (IterT m a) where
  IterT m a
x <> :: IterT m a -> IterT m a -> IterT m a
<> IterT m a
y = forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall a b. (a -> b) -> a -> b
$ do
    Either a (IterT m a)
x' <- forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT IterT m a
x
    Either a (IterT m a)
y' <- forall (m :: * -> *) a. IterT m a -> m (Either a (IterT m a))
runIterT IterT m a
y
    case (Either a (IterT m a)
x', Either a (IterT m a)
y') of
      ( Left a
a, Left a
b)  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left  forall a b. (a -> b) -> a -> b
$ a
a forall a. Semigroup a => a -> a -> a
<> a
b
      ( Left a
a, Right IterT m a
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
a forall a. Semigroup a => a -> a -> a
<>) IterT m a
b
      (Right IterT m a
a, Left a
b)  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Semigroup a => a -> a -> a
<> a
b) IterT m a
a
      (Right IterT m a
a, Right IterT m a
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IterT m a
a forall a. Semigroup a => a -> a -> a
<> IterT m a
b

deriving instance
  ( Typeable m
  , Data (m (Either a (IterT m a)))
  , Data a
  ) => Data (IterT m a)

{- $examples

* <examples/MandelbrotIter.lhs Rendering the Mandelbrot set>

* <examples/Cabbage.lhs The wolf, the sheep and the cabbage>

-}