{-# 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 :: NonEmpty a -> Maybe (NonEmpty a)
unwrap (a
_ :| [])       = Maybe (NonEmpty a)
forall a. Maybe a
Nothing
  unwrap (a
_ :| (a
a : [a]
as)) = NonEmpty a -> Maybe (NonEmpty a)
forall a. a -> Maybe a
Just (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as)

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

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

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

instance ComonadCofree f w => ComonadCofree f (EnvT e w) where
  unwrap :: EnvT e w a -> f (EnvT e w a)
unwrap (EnvT e
e w a
wa) = e -> w a -> EnvT e w a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e (w a -> EnvT e w a) -> f (w a) -> f (EnvT e w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w a -> f (w a)
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 :: StoreT s w a -> f (StoreT s w a)
unwrap (StoreT w (s -> a)
wsa s
s) = (w (s -> a) -> s -> StoreT s w a)
-> s -> w (s -> a) -> StoreT s w a
forall a b c. (a -> b -> c) -> b -> a -> c
flip w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT s
s (w (s -> a) -> StoreT s w a) -> f (w (s -> a)) -> f (StoreT s w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (s -> a) -> f (w (s -> a))
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 :: TracedT m w a -> f (TracedT m w a)
unwrap (TracedT w (m -> a)
wma) = w (m -> a) -> TracedT m w a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> a) -> TracedT m w a)
-> f (w (m -> a)) -> f (TracedT m w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (m -> a) -> f (w (m -> a))
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w (m -> a)
wma