```{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Functor.Internal.Ideal
-- Copyright   :  (C) 2008 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
----------------------------------------------------------------------------
module Control.Functor.Internal.Ideal
(
-- * Ideal Monads
, Ideal
, ideal
, destroyIdeal
-- * Coideal Comonads
, Coideal
, coideal
, buildCoideal
-- * Mutual recursion for (co)ideal (co)monad (co)products
, Mutual(..)
-- * Coideal Comonad Product
, (:*)
-- * Ideal Monad Coproduct
, (:+)
) where

import Prelude hiding (fst, snd)
import Control.Category.Cartesian
import Control.Functor
import Control.Functor.Algebra
import Control.Functor.Combinators.Lift

type Ideal = Ap Either
-- type Ideal f = Join (PFree f)
type Coideal = Ap (,)
-- type Coideal f = Join (PCofree f)

ideal :: Either a (f a) -> Ideal f a
ideal = mkAp

coideal :: (a, f a) -> Coideal f a
coideal = mkAp

runIdeal :: Ideal f a -> Either a (f a)
runIdeal = runAp

runCoideal :: Coideal f a -> (a, f a)
runCoideal = runAp

class Functor m => MonadIdeal m where
idealize :: m (Either a (m a)) -> m a

instance Functor f => Pointed (Ideal f) where
point = Lift . Left . Identity

-- this only really needs 'ap' but there is no 'unpointed/pre- applicative'
{-
instance Applicative f => Applicative (Ideal f) where
pure = point
Ideal (Left f) <*> Ideal (Left a) = Ideal \$ Left (f a)
Ideal (Left f) <*> Ideal (Right bs) = Ideal \$ Right (fmap f bs)
Ideal (Right fs) <*> Ideal (Left a) = Ideal \$ Right (fmap (\$a) fs)
Ideal (Right fs) <*> Ideal (Right bs) = Ideal \$ Right (fs <*> bs)
-}

instance MonadIdeal m => Monad (Ideal m) where
return = point
m >>= f = ideal . (id ||| Right . idealize) . runIdeal \$ fmap (runIdeal . f) m

destroyIdeal :: Algebra m a -> Ideal m a -> a
destroyIdeal phi = (id ||| phi) . runIdeal

-- instance MonadIdeal (Fst k) where
--	idealize = mkFst . runFst

class Functor w => ComonadCoideal w where
coidealize :: w a -> w (a, w a)

instance Functor f => Copointed (Coideal f) where
extract = runIdentity . fst . runLift

instance ComonadCoideal w => Comonad (Coideal w) where
extend f = fmap (f . coideal) . coideal . (id &&& coidealize . snd) . runCoideal

buildCoideal :: Coalgebra m a -> a -> Coideal m a
buildCoideal phi = coideal . (id &&& phi)

-- instance ComonadCoideal (Fst k) where
--	coidealize = mkFst . runFst

-- * (Co)ideal (Co)products

newtype Mutual p m n a = Mutual { runMutual :: m (p a (Mutual p n m a)) }
type Mutual' p m n = Lift p (Mutual p m n) (Mutual p n m)
type (m :+ n) = Mutual' Either m n
type (m :* n) = Mutual' (,) m n

instance (Bifunctor p Hask Hask Hask, Functor m, Functor n) => Functor (Mutual p m n) where
fmap f = Mutual . fmap (bimap f (fmap f)) . runMutual

{-
instance (MonadIdeal m, MonadIdeal n) => MonadIdeal (m :+ n) where
idealize = undefined
-}

{-
instance (ComonadCoideal w, ComonadCoideal v) => ComonadCoideal (w :* v) where
coidealize = undefined
-}
```