{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE UndecidableInstances #-}
#include "free-common.h"

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

-- |

-- Module      :  Control.Comonad.Cofree.Class

-- Copyright   :  (C) 2008-2011 Edward Kmett

-- License     :  BSD-style (see the file LICENSE)

--

-- Maintainer  :  Edward Kmett <ekmett@gmail.com>

-- Stability   :  experimental

-- Portability :  fundeps, MPTCs

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

module Control.Comonad.Cofree.Class
  ( ComonadCofree(..)
  ) where

import Control.Applicative
import Control.Comonad
import Control.Comonad.Trans.Env
import Control.Comonad.Trans.Store
import Control.Comonad.Trans.Traced
import Control.Comonad.Trans.Identity
import Data.List.NonEmpty (NonEmpty(..))
import Data.Tree
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif

-- | Allows you to peel a layer off a cofree comonad.

class (Functor f, Comonad w) => ComonadCofree f w | w -> f where
  -- | Remove a layer.

  unwrap :: w a -> f (w a)

instance ComonadCofree Maybe NonEmpty where
  unwrap :: forall a. NonEmpty a -> Maybe (NonEmpty a)
unwrap (a
_ :| [])       = forall a. Maybe a
Nothing
  unwrap (a
_ :| (a
a : [a]
as)) = forall a. a -> Maybe a
Just (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as)

instance ComonadCofree [] Tree where
  unwrap :: forall a. Tree a -> [Tree a]
unwrap = forall a. Tree a -> [Tree a]
subForest

instance ComonadCofree (Const b) ((,) b) where
  unwrap :: forall a. (b, a) -> Const b (b, a)
unwrap = forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

instance ComonadCofree f w => ComonadCofree f (IdentityT w) where
  unwrap :: forall a. IdentityT w a -> f (IdentityT w a)
unwrap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT

instance ComonadCofree f w => ComonadCofree f (EnvT e w) where
  unwrap :: forall a. EnvT e w a -> f (EnvT e w a)
unwrap (EnvT e
e w a
wa) = forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w a
wa

instance ComonadCofree f w => ComonadCofree f (StoreT s w) where
  unwrap :: forall a. StoreT s w a -> f (StoreT s w a)
unwrap (StoreT w (s -> a)
wsa s
s) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w (s -> a)
wsa

instance (ComonadCofree f w, Monoid m) => ComonadCofree f (TracedT m w) where
  unwrap :: forall a. TracedT m w a -> f (TracedT m w a)
unwrap (TracedT w (m -> a)
wma) = forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w (m -> a)
wma