content: {-# LANGUAGE CPP, ScopedTypeVariables #-}
  -- |The ROS Topic type and basic operations on Topics.
  --
  -- /Note/: Many of these operations have the same names as similar
  -- operations on lists in the "Prelude". The ambiguity may be resolved
  -- using either qualification (e.g. @import qualified Ros.TopicUtil as
  -- T@), an explicit import list, or a @hiding@ clause.
  module Ros.Topic where
  #if __GLASGOW_HASKELL__ < 710
  import Control.Applicative
  #endif
  import Control.Arrow ((***), second)
  import Control.Monad ((<=<), (>=>))
  import Control.Monad.IO.Class
  
  -- |A Topic is an infinite stream of values that steps between values
  -- in a 'Monad'.
  newtype Topic m a = Topic { runTopic :: m (a, Topic m a) }
  
  instance Functor m => Functor (Topic m) where
    fmap f (Topic ma) = Topic $ fmap (f *** fmap f) ma
  
  instance Applicative m => Applicative (Topic m) where
    pure x = let t = Topic $ pure (x, t) in t
    Topic ma <*> Topic mb = Topic $ uncurry (***) . (($) *** (<*>)) <$> ma <*> mb
  
  -- |Return the first value produced by a 'Topic'.
  head :: Functor m => Topic m a -> m a
  head = fmap fst . runTopic
  
  -- |Return the first value produced by a 'Topic' along with the
  -- remaining 'Topic' data.
  uncons :: Topic m a -> m (a, Topic m a)
  uncons = runTopic
  
  -- |Force evaluation of a topic until it produces a value.
  force :: Monad m => Topic m a -> m (Topic m a)
  force = uncons >=> return . Topic . return
  
  -- |Prepend a single item to the front of a 'Topic'.
  cons :: Monad m => a -> Topic m a -> Topic m a
  cons x t = Topic $ return (x, t)
  
  -- |Returns a 'Topic' containing all the values from the given 'Topic'
  -- after the first.
  tail :: Monad m => Topic m a -> Topic m a
  tail = Topic . (runTopic . snd <=< runTopic)
  
  -- |Return a 'Topic' of all the suffixes of a 'Topic'.
  tails :: Monad m => Topic m a -> Topic m (Topic m a)
  tails t = Topic $ do (x,t') <- runTopic t
                       return (Topic $ return (x,t'), tails t')
  
  -- |Returns a 'Topic' containing only those elements of the supplied
  -- 'Topic' for which the given predicate returns 'True'.
  filter :: Monad m => (a -> Bool) -> Topic m a -> Topic m a
  filter p = metamorph go
    where go x | p x = yield x go
               | otherwise = skip go
  -- filter p = go 
  --   where go = Topic . (aux <=< runTopic)
  --         aux (x, t') | p x       = return (x, go t')
  --                     | otherwise = runTopic $ go t'
  
  -- |@take n t@ returns the prefix of @t@ of length @n@.
  take :: Monad m => Int -> Topic m a -> m [a]
  take = aux []
    where aux acc 0 _ = return (reverse acc)
          aux acc n' t = do (x, t') <- runTopic t
                            aux (x:acc) (n'-1) t'
  
  -- |Run a 'Topic' for the specified number of iterations, discarding
  -- the values it produces.
  take_ :: Monad m => Int -> Topic m a -> m ()
  take_ 0 = const $ return ()
  take_ n = take_ (n-1) . snd <=< runTopic
  
  -- |@drop n t@ returns the suffix of @t@ after the first @n@ elements.
  drop :: Monad m => Int -> Topic m a -> Topic m a
  drop = (Topic .) . aux
    where aux 0 = runTopic
          aux n = aux (n-1) . snd <=< runTopic
  
  -- |@dropWhile p t@ returns the suffix of @t@ after all elements
  -- satisfying predicate @p@ have been dropped.
  dropWhile :: Monad m => (a -> Bool) -> Topic m a -> Topic m a
  dropWhile p = Topic . go
    where go = check <=< runTopic
          check (x,t) | p x       = go t
                      | otherwise = return (x, t)
  
  -- |@takeWhile p t@ returns the longest prefix (possibly empty) of @t@
  -- all of whose elements satisfy the predicate @p@.
  takeWhile :: Monad m => (a -> Bool) -> Topic m a -> m [a]
  takeWhile p = go []
    where go acc t = do (x,t') <- runTopic t
                        if p x then go (x:acc) t' 
                               else return . reverse $ x:acc
  
  -- |@break p t@ returns a tuple whose first element is the longest
  -- prefix (possibly empty) of @t@ all of whose elements satisfy the
  -- predicate @p@, and whose second element is the remainder of the
  -- 'Topic'.
  break :: Monad m => (a -> Bool) -> Topic m a -> m ([a], Topic m a)
  break p = go []
    where go acc = check acc <=< runTopic
          check acc (x,t)
            | p x = go (x:acc) t
            | otherwise = return (reverse (x:acc), t)
  
  -- |@splitAt n t@ returns a tuple whose first element is the prefix of
  -- @t@ of length @n@, and whose second element is the remainder of the
  -- 'Topic'.
  splitAt :: Monad m => Int -> Topic m a -> m ([a], Topic m a)
  splitAt = go []
    where go acc 0 t = return (reverse acc, t)
          go acc n t = do (x,t') <- runTopic t
                          go (x:acc) (n-1) t'
  
  -- |Returns a 'Topic' that includes only the 'Just' values from the
  -- given 'Topic'.
  catMaybes :: Monad m => Topic m (Maybe a) -> Topic m a
  catMaybes = metamorph go
    where go = maybe (skip go) (flip yield go)
  -- catMaybes (Topic ma) = Topic $ ma >>= aux
  --   where aux (Nothing, t') = runTopic $ catMaybes t'
  --         aux (Just x, t')  = return (x, catMaybes t')
  
  -- |Repeatedly execute a monadic action feeding the values into a
  -- 'Topic'.
  repeatM :: Monad m => m a -> Topic m a
  repeatM action = go
    where go = Topic $ action >>= \x -> return (x, go)
  
  -- |Build a 'Topic' from a seed value. The supplied function is
  -- applied to the seed value to produce both a value that goes into
  -- the 'Topic' and a new seed value for the next recursive call.
  unfold :: Functor m => (b -> m (a,b)) -> b -> Topic m a
  unfold f z0 = go z0
    where go z = Topic $ second go <$> f z
  
  -- |A pair of an optional value and a continuation for producing more
  -- such pairs. This type is used by 'metamorph' to implement a
  -- streaming @unfold . fold@ composition.
  newtype IterCont a b = IterCont (Maybe b, a -> IterCont a b)
  
  instance Functor (IterCont a) where
    fmap f (IterCont (x, k)) = IterCont (fmap f x, fmap f . k)
  
  -- |A pair of an optional value and a continuation with effects for
  -- producing more such pairs. This type is used by 'metamorphM' to
  -- implement a streaming @unfold . fold@ composition.
  newtype IterContM m a b = IterContM (Maybe b, a -> m (IterContM m a b))
  
  instance Monad m => Functor (IterContM m a) where
    fmap f (IterContM (x, k)) = IterContM (fmap f x,  return . fmap f <=< k)
  
  -- |Yield a value and a continuation in a metamorphism (used with
  -- 'metamorph').
  yield :: b -> (a -> IterCont a b) -> IterCont a b
  yield = curry IterCont . Just
  
  -- |Do not yield a value, but provide a continuation in a metamorphism
  -- (used with 'metamorph').
  skip :: (a -> IterCont a b) -> IterCont a b
  skip = curry IterCont Nothing
  
  -- |Yield a value and a continuation in a monad as part of a monadic
  -- metamorphism (used with 'metamorphM').
  yieldM :: Monad m => b -> (a -> m (IterContM m a b)) -> m (IterContM m a b)
  yieldM = (return .) . curry IterContM . Just
  
  -- |Do not yield a value, but provide a continuation in a metamorphism
  -- (used with 'metamorphM').
  skipM :: Monad m => (a -> m (IterContM m a b)) -> m (IterContM m a b)
  skipM = return . curry IterContM Nothing
  
  -- |A metamorphism (cf. Jeremy Gibbons) on 'Topic's. This is an
  -- /unfold/ following a /fold/ (i.e. @unfoldr . foldl@), with the
  -- expectation that partial results of the /unfold/ may be returned
  -- before the /fold/ is completed. The supplied function produces a
  -- optional value and a continuation when applied to an element of the
  -- first 'Topic'. The value is returned by the new 'Topic' if it is
  -- not 'Nothing', and the continuation is used to produce the rest of
  -- the returned 'Topic'.
  metamorph :: Monad m => (a -> IterCont a b) -> Topic m a -> Topic m b
  metamorph f t = Topic $ do (x,t') <- runTopic t
                             let IterCont (x', f') = f x
                             case x' of
                               Nothing -> runTopic $ metamorph f' t'
                               Just x'' -> return (x'', metamorph f' t')
  
  -- |Similar to 'metamorph', but the metamorphism may have effects.
  metamorphM :: Monad m => (a -> m (IterContM m a b)) -> Topic m a -> Topic m b
  metamorphM f t = Topic $ do (x,t') <- runTopic t
                              IterContM (x', f') <- f x
                              case x' of
                                Nothing -> runTopic $ metamorphM f' t'
                                Just x'' -> return (x'', metamorphM f' t')
  
  -- |Fold two functions along a 'Topic' collecting their productions in
  -- a new 'Topic'.
  bimetamorph :: Monad m =>
                 (a -> IterCont a b) -> (a -> IterCont a b) ->
                 Topic m a -> Topic m b
  bimetamorph f g t = Topic $ do (x,t') <- runTopic t
                                 let IterCont (y, f') = f x
                                     IterCont (z, g') = g x
                                 aux y . aux z . runTopic $ bimetamorph f' g' t'
    where aux = maybe id (\x y -> return (x, Topic y))
  
  -- |Fold two monadic functions along a 'Topic' collecting their
  -- productions in a new 'Topic'.
  bimetamorphM :: Monad m =>
                  (a -> m (IterContM m a b)) -> (a -> m (IterContM m a b)) ->
                  Topic m a -> Topic m b
  bimetamorphM f g t = Topic $ do (x,t') <- runTopic t
                                  IterContM (y, f') <- f x
                                  IterContM (z, g') <- g x
                                  aux y . aux z . runTopic $ bimetamorphM f' g' t'
    where aux = maybe id (\x y -> return (x, Topic y))
  
  -- |Fold two functions along a 'Topic' collecting and tagging their
  -- productions in a new 'Topic'.
  bimetamorphE :: Monad m => 
                  (a -> IterCont a b) -> (a -> IterCont a c) ->
                  Topic m a -> Topic m (Either b c)
  bimetamorphE f g t = bimetamorph (fmap Left . f) (fmap Right . g) t
  
  -- |Fold two monadic functions along a 'Topic' collecting and tagging
  -- their productions in a new 'Topic'.
  bimetamorphME :: Monad m => 
                   (a -> m (IterContM m a b)) -> (a -> m (IterContM m a c)) ->
                   Topic m a -> Topic m (Either b c)
  bimetamorphME f g t = 
    bimetamorphM (return . fmap Left <=< f) (return . fmap Right <=< g) t
  
  -- |Removes one level of monadic structure from the values a 'Topic'
  -- produces.
  join :: (Functor m, Monad m) => Topic m (m a) -> Topic m a
  join t = Topic $ do (x, t') <- runTopic t
                      x' <- x
                      return (x', join t')
  
  -- |@forever t@ runs all monadic actions a 'Topic' produces. This is
  -- useful for 'Topic's whose steps produce side-effects, but not
  -- useful pure values.
  forever :: Monad m => Topic m a -> m b
  forever = forever . snd <=< runTopic
  
  -- |Map a monadic action over a 'Topic'.
  mapM :: (Functor m, Monad m) => (a -> m b) -> Topic m a -> Topic m b
  mapM = (join .) . fmap
  
  -- |Map a monadic action of a 'Topic' purely for its side
  -- effects. This function will never return.
  mapM_ :: Monad m => (a -> m ()) -> Topic m a -> m ()
  mapM_ f = go
    where go = uncurry (>>) . (f *** go) <=< runTopic
  
  -- |A left-associative scan of a 'Topic' is a fold whose every
  -- intermediate value is produced as a value of a new 'Topic'.
  scan :: Monad m => (a -> b -> a) -> a -> Topic m b -> Topic m a
  scan f z = metamorph (go z)
    where go acc x = let x' = f acc x in yield x' (go x')
  
  -- |Print all the values produced by a 'Topic'.
  showTopic :: (MonadIO m, Functor m, Show a) => Topic m a -> Topic m ()
  showTopic = join . fmap (liftIO . putStrLn . show)
  
  