content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE Safe #-}
  {-# LANGUAGE StandaloneDeriving #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Control.Comonad.Cofree
  -- Copyright   :  (C) 2008-2013 Edward Kmett
  -- License     :  BSD-style (see the file LICENSE)
  --
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  provisional
  -- Portability :  MPTCs, fundeps
  --
  -- Cofree comonads
  --
  ----------------------------------------------------------------------------
  module Control.Comonad.Cofree
    ( Cofree(..)
    , ComonadCofree(..)
    , section
    , coiter
    , coiterW
    , unfold
    , unfoldM
    , hoistCofree
    -- * Lenses into cofree comonads
    , _extract
    , _unwrap
    , telescoped
    , telescoped_
    , shoots
    , leaves
    ) where
  
  import Control.Applicative
  import Control.Comonad
  import Control.Comonad.Trans.Class
  import Control.Comonad.Cofree.Class
  import Control.Comonad.Env.Class
  import Control.Comonad.Store.Class as Class
  import Control.Comonad.Traced.Class
  import Control.Comonad.Hoist.Class
  import Control.Category
  import Control.Monad(ap, (>=>), liftM)
  import Control.Monad.Zip
  import Data.Functor.Bind
  import Data.Functor.Classes
  import Data.Functor.Extend
  import Data.Functor.WithIndex
  import Data.Data
  import Data.Distributive
  import Data.Foldable
  import Data.Foldable.WithIndex
  import Data.Semigroup
  import Data.Traversable
  import Data.Traversable.WithIndex
  import Data.Semigroup.Foldable
  import Data.Semigroup.Traversable
  import GHC.Generics hiding (Infix, Prefix)
  import Prelude hiding (id,(.))
  
  
  infixr 5 :<
  
  -- | The 'Cofree' 'Comonad' of a functor @f@.
  --
  -- /Formally/
  --
  -- A 'Comonad' @v@ is a cofree 'Comonad' for @f@ if every comonad homomorphism
  -- from another comonad @w@ to @v@ is equivalent to a natural transformation
  -- from @w@ to @f@.
  --
  -- A 'cofree' functor is right adjoint to a forgetful functor.
  --
  -- Cofree is a functor from the category of functors to the category of comonads
  -- that is right adjoint to the forgetful functor from the category of comonads
  -- to the category of functors that forgets how to 'extract' and
  -- 'duplicate', leaving you with only a 'Functor'.
  --
  -- In practice, cofree comonads are quite useful for annotating syntax trees,
  -- or talking about streams.
  --
  -- A number of common comonads arise directly as cofree comonads.
  --
  -- For instance,
  --
  -- * @'Cofree' 'Maybe'@ forms the comonad for a non-empty list.
  --
  -- * @'Cofree' ('Const' b)@ is a product.
  --
  -- * @'Cofree' 'Identity'@ forms an infinite stream.
  --
  -- * @'Cofree' ((->) b)'@ describes a Moore machine with states labeled with values of type a, and transitions on edges of type b.
  --
  -- Furthermore, if the functor @f@ forms a monoid (for example, by
  -- being an instance of 'Alternative'), the resulting 'Comonad' is
  -- also a 'Monad'. See
  -- <http://www.cs.appstate.edu/~johannp/jfp06-revised.pdf Monadic Augment and Generalised Shortcut Fusion> by Neil Ghani et al., Section 4.3
  -- for more details.
  --
  -- In particular, if @f a ≡ [a]@, the
  -- resulting data structure is a <https://en.wikipedia.org/wiki/Rose_tree Rose tree>.
  -- For a practical application, check
  -- <https://web.archive.org/web/20161208002902/http://www.cs.le.ac.uk/people/ak155/Papers/CALCO-07/GK07.pdf Higher Dimensional Trees, Algebraically> by Neil Ghani et al.
  data Cofree f a = a :< f (Cofree f a)
    deriving (Generic, Generic1)
  
  deriving instance (Typeable f, Data (f (Cofree f a)), Data a) => Data (Cofree f a)
  
  -- | Use coiteration to generate a cofree comonad from a seed.
  --
  -- @'coiter' f = 'unfold' ('id' 'Control.Arrow.&&&' f)@
  coiter :: Functor f => (a -> f a) -> a -> Cofree f a
  coiter psi a = a :< (coiter psi <$> psi a)
  
  -- | Like coiter for comonadic values.
  coiterW :: (Comonad w, Functor f) => (w a -> f (w a)) -> w a -> Cofree f a
  coiterW psi a = extract a :< (coiterW psi <$> psi a)
  
  -- | Unfold a cofree comonad from a seed.
  unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a
  unfold f c = case f c of
    (x, d) -> x :< fmap (unfold f) d
  
  -- | Unfold a cofree comonad from a seed, monadically.
  unfoldM :: (Traversable f, Monad m) => (b -> m (a, f b)) -> b -> m (Cofree f a)
  unfoldM f = f >=> \ (x, t) -> (x :<) `liftM` Data.Traversable.mapM (unfoldM f) t
  
  hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a
  hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y)
  
  instance Functor f => ComonadCofree f (Cofree f) where
    unwrap (_ :< as) = as
    {-# INLINE unwrap #-}
  
  instance Distributive f => Distributive (Cofree f) where
    distribute w = fmap extract w :< fmap distribute (collect unwrap w)
  
  instance Functor f => Functor (Cofree f) where
    fmap f (a :< as) = f a :< fmap (fmap f) as
    b <$ (_ :< as) = b :< fmap (b <$) as
  
  instance Functor f => Extend (Cofree f) where
    extended = extend
    {-# INLINE extended #-}
    duplicated = duplicate
    {-# INLINE duplicated #-}
  
  instance Functor f => Comonad (Cofree f) where
    extend f w = f w :< fmap (extend f) (unwrap w)
    duplicate w = w :< fmap duplicate (unwrap w)
    extract (a :< _) = a
    {-# INLINE extract #-}
  
  -- | This is not a true 'Comonad' transformer, but this instance is convenient.
  instance ComonadTrans Cofree where
    lower (_ :< as) = fmap extract as
    {-# INLINE lower #-}
  
  instance Alternative f => Monad (Cofree f) where
    return = pure
    {-# INLINE return #-}
    (a :< m) >>= k = case k a of
                       b :< n -> b :< (n <|> fmap (>>= k) m)
  
  instance (Alternative f, MonadZip f) => MonadZip (Cofree f) where
    mzip (a :< as) (b :< bs) = (a, b) :< fmap (uncurry mzip) (mzip as bs)
  
  -- |
  --
  -- @'lower' . 'section' = 'id'@
  section :: Comonad f => f a -> Cofree f a
  section as = extract as :< extend section as
  
  instance Apply f => Apply (Cofree f) where
    (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as)
    {-# INLINE (<.>) #-}
    (f :< fs) <.  (_ :< as) = f :< ((<. ) <$> fs <.> as)
    {-# INLINE (<.) #-}
    (_ :< fs)  .> (a :< as) = a :< (( .>) <$> fs <.> as)
    {-# INLINE (.>) #-}
  
  instance ComonadApply f => ComonadApply (Cofree f) where
    (f :< fs) <@> (a :< as) = f a :< ((<@>) <$> fs <@> as)
    {-# INLINE (<@>) #-}
    (f :< fs) <@  (_ :< as) = f :< ((<@ ) <$> fs <@> as)
    {-# INLINE (<@) #-}
    (_ :< fs)  @> (a :< as) = a :< (( @>) <$> fs <@> as)
    {-# INLINE (@>) #-}
  
  instance Alternative f => Applicative (Cofree f) where
    pure x = x :< empty
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}
  
  instance (Show1 f) => Show1 (Cofree f) where
    liftShowsPrec sp sl = go
      where
        goList = liftShowList sp sl
        go d (a :< as) = showParen (d > 5) $
          sp 6 a . showString " :< " . liftShowsPrec go goList 5 as
  
  instance (Show1 f, Show a) => Show (Cofree f a) where
    showsPrec = showsPrec1
  
  instance (Read1 f) => Read1 (Cofree f) where
    liftReadsPrec rp rl = go
      where
        goList = liftReadList rp rl
        go d r = readParen (d > 5)
          (\r' -> [(u :< v, w) |
                  (u, s) <- rp 6 r',
                  (":<", t) <- lex s,
                  (v, w) <- liftReadsPrec go goList 5 t]) r
  
  instance (Read1 f, Read a) => Read (Cofree f a) where
    readsPrec = readsPrec1
  
  instance (Eq1 f, Eq a) => Eq (Cofree f a) where
    (==) = eq1
  
  instance (Eq1 f) => Eq1 (Cofree f) where
    liftEq eq = go
      where
        go (a :< as) (b :< bs) = eq a b && liftEq go as bs
  
  instance (Ord1 f, Ord a) => Ord (Cofree f a) where
    compare = compare1
  
  instance (Ord1 f) => Ord1 (Cofree f) where
    liftCompare cmp = go
      where
        go (a :< as) (b :< bs) = cmp a b `mappend` liftCompare go as bs
  
  instance Foldable f => Foldable (Cofree f) where
    foldMap f = go where
      go (a :< as) = f a `mappend` foldMap go as
    {-# INLINE foldMap #-}
    length = go 0 where
      go s (_ :< as) = foldl' go (s + 1) as
  
  instance Foldable1 f => Foldable1 (Cofree f) where
    foldMap1 f = go where
      go (a :< as) = f a <> foldMap1 go as
    {-# INLINE foldMap1 #-}
  
  instance Traversable f => Traversable (Cofree f) where
    traverse f = go where
      go (a :< as) = (:<) <$> f a <*> traverse go as
    {-# INLINE traverse #-}
  
  instance Traversable1 f => Traversable1 (Cofree f) where
    traverse1 f = go where
      go (a :< as) = (:<) <$> f a <.> traverse1 go as
    {-# INLINE traverse1 #-}
  
  instance FunctorWithIndex i f => FunctorWithIndex [i] (Cofree f) where
    imap f (a :< as) = f [] a :< imap (\i -> imap (f . (:) i)) as
    {-# INLINE imap #-}
  
  instance FoldableWithIndex i f => FoldableWithIndex [i] (Cofree f) where
    ifoldMap f (a :< as) = f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as
    {-# INLINE ifoldMap #-}
  
  instance TraversableWithIndex i f => TraversableWithIndex [i] (Cofree f) where
    itraverse f (a :< as) = (:<) <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as
    {-# INLINE itraverse #-}
  
  instance ComonadHoist Cofree where
    cohoist = hoistCofree
  
  instance ComonadEnv e w => ComonadEnv e (Cofree w) where
    ask = ask . lower
    {-# INLINE ask #-}
  
  instance ComonadStore s w => ComonadStore s (Cofree w) where
    pos (_ :< as) = Class.pos as
    {-# INLINE pos #-}
    peek s (_ :< as) = extract (Class.peek s as)
    {-# INLINE peek #-}
  
  instance ComonadTraced m w => ComonadTraced m (Cofree w) where
    trace m = trace m . lower
    {-# INLINE trace #-}
  
  -- | This is a lens that can be used to read or write from the target of 'extract'.
  --
  -- Using (^.) from the @lens@ package:
  --
  -- @foo ^. '_extract' == 'extract' foo@
  --
  -- For more on lenses see the @lens@ package on hackage
  --
  -- @'_extract' :: Lens' ('Cofree' g a) a@
  _extract :: Functor f => (a -> f a) -> Cofree g a -> f (Cofree g a)
  _extract f (a :< as) = (:< as) <$> f a
  {-# INLINE _extract #-}
  
  -- | This is a lens that can be used to read or write to the tails of a 'Cofree' 'Comonad'.
  --
  -- Using (^.) from the @lens@ package:
  --
  -- @foo ^. '_unwrap' == 'unwrap' foo@
  --
  -- For more on lenses see the @lens@ package on hackage
  --
  -- @'_unwrap' :: Lens' ('Cofree' g a) (g ('Cofree' g a))@
  _unwrap :: Functor f => (g (Cofree g a) -> f (g (Cofree g a))) -> Cofree g a -> f (Cofree g a)
  _unwrap  f (a :< as) = (a :<) <$> f as
  {-# INLINE _unwrap #-}
  
  -- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor.
  -- When the input list is empty, this is equivalent to '_extract'.
  -- When the input list is non-empty, this composes the input lenses
  -- with '_unwrap' to walk through the @'Cofree' g@ before using
  -- '_extract' to get the element at the final location.
  --
  -- For more on lenses see the 'lens' package on hackage.
  --
  -- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)]      -> Lens' ('Cofree' g a) a@
  --
  -- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) a@
  --
  -- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)]     -> Getter ('Cofree' g a) a@
  --
  -- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)]       -> Fold ('Cofree' g a) a@
  --
  -- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)]    -> Setter' ('Cofree' g a) a@
  telescoped :: Functor f =>
               [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->
                (a -> f a) -> Cofree g a -> f (Cofree g a)
  telescoped = Prelude.foldr (\l r -> _unwrap . l . r) _extract
  {-# INLINE telescoped #-}
  
  -- not actually named 'eats'
  -- | Construct an @Lens@ into a @'Cofree' g@ given a list of lenses into the base functor.
  -- The only difference between this and 'telescoped' is that 'telescoped' focuses on a single value, but this focuses on the entire remaining subtree.
  -- When the input list is empty, this is equivalent to 'id'.
  -- When the input list is non-empty, this composes the input lenses
  -- with '_unwrap' to walk through the @'Cofree' g@.
  --
  -- For more on lenses see the 'lens' package on hackage.
  --
  -- @telescoped :: [Lens' (g ('Cofree' g a)) ('Cofree' g a)]      -> Lens' ('Cofree' g a) ('Cofree' g a)@
  --
  -- @telescoped :: [Traversal' (g ('Cofree' g a)) ('Cofree' g a)] -> Traversal' ('Cofree' g a) ('Cofree' g a)@
  --
  -- @telescoped :: [Getter (g ('Cofree' g a)) ('Cofree' g a)]     -> Getter ('Cofree' g a) ('Cofree' g a)@
  --
  -- @telescoped :: [Fold (g ('Cofree' g a)) ('Cofree' g a)]       -> Fold ('Cofree' g a) ('Cofree' g a)@
  --
  -- @telescoped :: [Setter' (g ('Cofree' g a)) ('Cofree' g a)]    -> Setter' ('Cofree' g a) ('Cofree' g a)@
  telescoped_ :: Functor f =>
                [(Cofree g a -> f (Cofree g a)) -> g (Cofree g a) -> f (g (Cofree g a))] ->
                (Cofree g a -> f (Cofree g a)) -> Cofree g a -> f (Cofree g a)
  telescoped_ = Prelude.foldr (\l r -> _unwrap . l . r) id
  {-# INLINE telescoped_ #-}
  
  -- | A @Traversal'@ that gives access to all non-leaf @a@ elements of a
  -- @'Cofree' g@ a, where non-leaf is defined as @x@ from @(x :< xs)@ where
  -- @null xs@ is @False@.
  --
  -- Because this doesn't give access to all values in the @'Cofree' g@,
  -- it cannot be used to change types.
  --
  -- @shoots :: Traversable g => Traversal' (Cofree g a) a@
  --
  -- N.B. On GHC < 7.9, this is slightly less flexible, as it has to
  -- use @null (toList xs)@ instead.
  shoots :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)
  shoots f = go
    where
      go xxs@(x :< xs) | null xs          = pure xxs
                       | otherwise        = (:<) <$> f x <*> traverse go xs
  {-# INLINE shoots #-}
  
  -- | A @Traversal'@ that gives access to all leaf @a@ elements of a
  -- @'Cofree' g@ a, where leaf is defined as @x@ from @(x :< xs)@ where
  -- @null xs@ is @True@.
  --
  -- Because this doesn't give access to all values in the @'Cofree' g@,
  -- it cannot be used to change types.
  --
  -- @shoots :: Traversable g => Traversal' (Cofree g a) a@
  --
  -- N.B. On GHC < 7.9, this is slightly less flexible, as it has to
  -- use @null (toList xs)@ instead.
  leaves :: (Applicative f, Traversable g) => (a -> f a) -> Cofree g a -> f (Cofree g a)
  leaves f = go
    where
      go (x :< xs) | null xs          = (:< xs) <$> f x
                   | otherwise        = (x :<) <$> traverse go xs
  {-# INLINE leaves #-}
  