{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Safe #-}
#else
-- Manual Typeable instances

{-# LANGUAGE Trustworthy #-}
#endif
#include "free-common.h"

-----------------------------------------------------------------------------

-- |

-- 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.Compat
import Data.Functor.Identity
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable
import Data.Typeable
import Data.Data

#if !(MIN_VERSION_base(4,8,0))
import Data.Foldable hiding (fold)
import Data.Traversable hiding (mapM)
#endif

#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)) }
#if __GLASGOW_HASKELL__ >= 707
  deriving (Typeable)
#endif

-- | 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 #-}

#ifdef LIFTED_FUNCTOR_CLASSES
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
#else
instance (Functor m, Eq1 m) => Eq1 (IterT m) where
  eq1 = on eq1 (fmap (fmap Lift1) . runIterT)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Eq1 m, Eq a) => Eq (IterT m a) where
#else
instance (Functor m, Eq1 m, Eq a) => Eq (IterT m a) where
#endif
  == :: IterT m a -> IterT m a -> Bool
(==) = forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1

#ifdef LIFTED_FUNCTOR_CLASSES
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
#else
instance (Functor m, Ord1 m) => Ord1 (IterT m) where
  compare1 = on compare1 (fmap (fmap Lift1) . runIterT)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Ord1 m, Ord a) => Ord (IterT m a) where
#else
instance (Functor m, Ord1 m, Ord a) => Ord (IterT m a) where
#endif
  compare :: IterT m a -> IterT m a -> Ordering
compare = forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1

#ifdef LIFTED_FUNCTOR_CLASSES
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
#else
instance (Functor m, Show1 m) => Show1 (IterT m) where
  showsPrec1 d (IterT m) = showParen (d > 10) $
    showString "IterT " . showsPrec1 11 (fmap (fmap Lift1) m)
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Show1 m, Show a) => Show (IterT m a) where
#else
instance (Functor m, Show1 m, Show a) => Show (IterT m a) where
#endif
  showsPrec :: Int -> IterT m a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

#ifdef LIFTED_FUNCTOR_CLASSES
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
#else
instance (Functor m, Read1 m) => Read1 (IterT m) where
  readsPrec1 d =  readParen (d > 10) $ \r ->
    [ (IterT (fmap (fmap lower1) m),t) | ("IterT",s) <- lex r, (m,t) <- readsPrec1 11 s]
#endif

#ifdef LIFTED_FUNCTOR_CLASSES
instance (Read1 m, Read a) => Read (IterT m a) where
#else
instance (Functor m, Read1 m, Read a) => Read (IterT m a) where
#endif
  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
#if MIN_VERSION_mtl(2,1,1)
  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 #-}
#endif

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 #-}
#if MIN_VERSION_mtl(2,1,1)
  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 #-}
#endif

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

#if __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
{-# NOINLINE freeTyCon #-}

#else
#define Typeable1 Typeable
#endif

instance
  ( Typeable1 m, Typeable a
  , Data (m (Either a (IterT m a)))
  , Data a
  ) => Data (IterT m a) where
    gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> IterT m a -> c (IterT m a)
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
f forall g. g -> c g
z (IterT m (Either a (IterT m a))
as) = forall g. g -> c g
z forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT forall d b. Data d => c (d -> b) -> d -> c b
`f` m (Either a (IterT m a))
as
    toConstr :: IterT m a -> Constr
toConstr IterT{} = Constr
iterConstr
    gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (IterT m a)
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
c = case Constr -> Int
constrIndex Constr
c of
        Int
1 -> forall b r. Data b => c (b -> r) -> c r
k (forall r. r -> c r
z forall (m :: * -> *) a. m (Either a (IterT m a)) -> IterT m a
IterT)
        Int
_ -> forall a. HasCallStack => String -> a
error String
"gunfold"
    dataTypeOf :: IterT m a -> DataType
dataTypeOf IterT m a
_ = DataType
iterDataType
    dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (IterT m a))
dataCast1 forall d. Data d => c (t d)
f  = forall {k1} {k2} (c :: k1 -> *) (t :: k2 -> k1) (t' :: k2 -> k1)
       (a :: k2).
(Typeable t, Typeable t') =>
c (t a) -> Maybe (c (t' a))
gcast1 forall d. Data d => c (t d)
f

iterConstr :: Constr
iterConstr :: Constr
iterConstr = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
iterDataType String
"IterT" [] Fixity
Prefix
{-# NOINLINE iterConstr #-}

iterDataType :: DataType
iterDataType :: DataType
iterDataType = String -> [Constr] -> DataType
mkDataType String
"Control.Monad.Iter.IterT" [Constr
iterConstr]
{-# NOINLINE iterDataType #-}

{- $examples

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

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

-}