-- | A module containing interleaving behaviour combinators.  See the 'engage'
--  function for some details and examples.  A much fuller explanation of this
--  entire library is provided in the forthcoming article in Issue 17 of The Monad
--  Reader which will be published at <http://themonadreader.wordpress.com/>.
module Control.Alternative.Interleave (
  InterleaveT, engage, engageMany, alongside, alongside_, alongsideMerge, endAfter, endWhen, once, once_, upTo, upTo_, inOrder, inOrder_,
    unlimited, unlimited_,
  unlimitedRecurse, unlimitedRecurse_) where

import Control.Applicative ((<$>), (<$), Alternative(..), Applicative(..))
import Data.Monoid (Monoid(mappend))
import Data.Traversable (sequenceA)

-- | This data-type represents potentially-many actions in the @f@
-- 'Monad' / 'Alternative' that will result in returning a value of type @a@.
-- See 'engage' for more details.
--
-- The 'Functor' instance is straightforward.  The '<*>' operator in the 'Applicative' instance
-- runs the left-hand side and right-hand side 'alongside' each other, and afterwards
-- it applies the left-hand function to the right-hand value.
data InterleaveT f a = Terminate { result :: a }
                     | NoMore    { result :: a }
                     | Continue  { result :: a, _rest :: f (InterleaveT f a) }

instance Functor f => Functor (InterleaveT f) where
  fmap f (Terminate x) = Terminate (f x)
  fmap f (NoMore x) = NoMore (f x)
  fmap f (Continue x m) = Continue (f x) (fmap f <$> m)

instance Alternative f => Applicative (InterleaveT f) where
  pure = NoMore
  (<*>) a b = uncurry ($) <$> (a `alongside` b)

-- | Acts like the given item, but when it has no more actions to take, ends the entire call to 'engage'.
-- So this code:
--
-- > engage $ unlimited p `alongside` endAfter (once q)
--
-- Will terminate after @q@ occurs.  In contrast, this code:
--
-- > engage $ unlimited p `alongside` once q
--
-- will never terminate because it can always offer to perform q.
endAfter :: Functor f => InterleaveT f a -> InterleaveT f a
endAfter (NoMore x) = Terminate x
endAfter (Terminate x) = Terminate x
endAfter (Continue x m) = Continue x (endAfter <$> m)

-- | Acts like the given item, but when the current result value satisfies the
-- given function (i.e. applying the function yields 'True'), ends the entire call
-- to 'engage'.
endWhen :: Functor f => (a -> Bool) -> InterleaveT f a -> InterleaveT f a
endWhen _ (Terminate x) = Terminate x
endWhen f (NoMore x) = if f x then Terminate x else NoMore x
endWhen f (Continue x m) = if f x then Terminate x else Continue x (endWhen f <$> m)

-- | Offers the given behaviour, and when it occurs, does not offer it again.
-- Returns @Just@ the result if the behaviour happens, otherwise gives @Nothing@.
--
-- @once m@ is equivalent to @listToMaybe \<$\> upTo 1 m@ (and thus also @listToMaybe
-- \<$\> inOrder [m]@).
once :: Functor f => f a -> InterleaveT f (Maybe a)
once m = Continue Nothing (NoMore . Just <$> m)

-- | Like 'once' but discards the result.
once_ :: Functor f => f a -> InterleaveT f ()
once_ m = Continue () (NoMore () <$ m)

-- | Offers the given behaviour up to the given number of times, returning a list
-- of the results (in chronological order, earliest first).
--
-- @upTo n@ is equivalent to @inOrder . replicate n@.
upTo :: Functor f => Int -> f a -> InterleaveT f [a]
upTo n = inOrder . replicate n

-- | Like 'upTo', but discards the results.
upTo_ :: Functor f => Int -> f a -> InterleaveT f ()
upTo_ n = inOrder_ . replicate n

-- | Offers the given list of items, in order.
inOrder :: Functor f => [f a] -> InterleaveT f [a]
inOrder [] = NoMore []
inOrder (m:ms) = Continue [] ((\x -> (x:) <$> inOrder ms) <$> m)

-- | Like 'inOrder', but discards the results.
inOrder_ :: Functor f => [f a] -> InterleaveT f ()
inOrder_ [] = NoMore ()
inOrder_ (m:ms) = Continue () (inOrder_ ms <$ m)

-- | Repeatedly offers the given behaviour.  A list is returned (in chronological order,
-- earliest first) of the results of each occurrence of the behaviour.  If you
-- don't want these results, it is better to use 'unlimited_' to avoid a space
-- leak.
--
-- @unlimited@ is equivalent to @inOrder . repeat@.
unlimited :: Functor f => f a -> InterleaveT f [a]
unlimited m = let b = Continue [] ((\x -> (x:) <$> b) <$> m) in b

-- | Like 'unlimited', but discards the output.  Useful if the event is likely
-- to occur many times, and you don't need the results.
unlimited_ :: Functor f => f a -> InterleaveT f ()
unlimited_ m = let b = Continue () (b <$ m) in b

-- | Like 'unlimited', but allows some state (of type @a@) to be passed from one
-- subsequent call to another, as well as generating the results of type @b@.
-- To begin with the function (first parameter) will be called with the initial
-- state (second parameter).  If chosen, it will return the new state, and a result
-- to be accumulated into the list.  The second call to the function will be passed
-- the new state, to then return the even newer state and a second result, and
-- so on.
--
-- If you want to use this with the StateT monad transformer from the mtl library,
-- you can call:
--
-- > unlimitedRecurse (runStateT myStateAction) initialState
-- >   where
-- >     myStateAction :: StateT s m a
-- >     initialState :: s
unlimitedRecurse :: Functor f => (a -> f (b, a)) -> a -> InterleaveT f [b]
unlimitedRecurse f = let b x = Continue [] ((\(r, y) -> (r :) <$> b y) <$> f x) in b

-- | Like 'unlimitedRecurse', but does not accumulate a list of results.
--
-- If you want to use this with the StateT monad transformer from the mtl library,
-- you can call:
--
-- > unlimitedRecurse (execStateT myStateAction) initialState
-- >   where
-- >     myStateAction :: StateT s m a
-- >     initialState :: s
unlimitedRecurse_ :: Functor f => (a -> f a) -> a -> InterleaveT f ()
unlimitedRecurse_ f = let b x = Continue () (b <$> f x) in b

-- | Offers one behaviour alongside another.
--
-- This operation is semantically associative and commutative.
alongside :: Alternative f => InterleaveT f a -> InterleaveT f b -> InterleaveT f (a, b)
alongside oa@(Continue a fa) ob@(Continue b fb)
  = Continue (a, b) ((flip alongside ob <$> fa) <|> (alongside oa <$> fb))
alongside (NoMore a) ob = (,) a <$> ob
alongside oa (NoMore b) = flip (,) b <$> oa
alongside oa ob = Terminate (result oa, result ob)

-- | Like 'alongside' but merges the results with 'mappend' afterwards.
--
-- @alongsideMerge a b@ is equivalent to @uncurry mappend \<$\> (a \`alongside\` b)@
-- and @liftA2 mappend a b@.
alongsideMerge :: (Alternative f, Monoid a) => InterleaveT f a -> InterleaveT f a -> InterleaveT f a 
alongsideMerge a b = uncurry mappend <$> alongside a b

-- | Like 'alongside' but discards the results.
alongside_ :: Alternative f => InterleaveT f a -> InterleaveT f b -> InterleaveT f ()
alongside_ (Continue _ fa) (Continue _ fb)
  = Continue () ((blank <$> fa) <|> (blank <$> fb))
alongside_ (NoMore _) b = blank b
alongside_ a (NoMore _) = blank a
alongside_ _ _ = Terminate ()

blank :: Functor f => f a -> f ()
blank = (() <$)

infixr `alongside`
infixr `alongside_`
infixr `alongsideMerge`

-- | Offers the given behaviour until either the finite set of actions is exhausted,
--    or one of the explicit termination constructs is triggered.
--
-- For example:
-- 
-- > engage $ unlimited p `alongside` unlimited q
-- 
-- will repeatedly offer @p@ and @q@ without ever terminating.
--
-- > engage $ upTo 3 p `alongside` upTo 5 q
--
-- will do @p@ three times and @q@ 5 times (in any mixed order) then finish.
-- 
-- > engage $ unlimited p `alongside` unlimited q `alongside` endAfter (once r)
-- 
-- will offer p repeatedly and q repeatedly and r, until r happens, at which point
-- the behaviour will end.
-- 
-- > engage $ once p `alongside` endAfter (once q)
-- 
-- will offer p and q; if p happens first it will wait for q, but if q happens
-- first it will finish.
-- 
-- > engage $ once p `alongside` endAfter (once q) `alongside` endAfter (once r)
-- 
-- permits p to happen at most once, while either of q or r happening will finish
-- the call.
--
-- All sorts of combinations are possible, but it is important to note that you
-- need at least one 'endAfter' or 'endWhen' event if you ever intend a call involving
-- 'unlimited' (or similar) to finish.  Some
-- laws involving 'engage' (ignoring the types and return values) are:
--
-- > engage (unlimited p) == forever p
-- > engage (once p) == Just <$> p
-- > engage (endAfter (once p)) == engage (once p)
-- > engage (endAfter (once p) `alongside` endAfter (once q)) == p <|> q
--
-- Most other uses of 'engage' and 'alongside' do not reduce down to simple
-- programs, which is of course the attraction of the combinators.
engage :: Monad f => InterleaveT f a -> f a
engage (Terminate x) = return x
engage (NoMore x) = return x
engage (Continue _ m) = m >>= engage

-- | Offers all the given behaviours together, and gives back a list of the outcomes.
--  
-- This is roughly a shorthand for @engage . foldr1 alongside@, except that if you
-- pass the empty list, you simply get the empty list returned (rather than an
-- error)
engageMany :: (Monad f, Alternative f) => [InterleaveT f a] -> f [a]
engageMany = engage . sequenceA